diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,8 @@ # Revision history for schemas +## 0.2.0.3 -- 2019-10-13 +* Bug fixes and performance improvements + ## 0.2.0.2 -- 2019-10-07 * Change the default schema for `Either` to handle both CamelCase and lowercase diff --git a/example/Person2.hs b/example/Person2.hs --- a/example/Person2.hs +++ b/example/Person2.hs @@ -7,6 +7,8 @@ import Control.Applicative import Data.Generics.Labels () +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE import Data.String import GHC.Exts (IsList(..)) import Person @@ -19,7 +21,7 @@ , age :: Int , addresses :: [String] , religion :: (Maybe Religion) -- new - , education :: Education -- renamed + , education :: NonEmpty Education -- renamed } deriving (Eq, Show) @@ -40,16 +42,19 @@ <*> field "age" Person2.age <*> field "addresses" Person2.addresses <*> optField "religion" Person2.religion - <*> (field "education" Person2.education <|> field "studies" Person2.education) + <*> (field "education" Person2.education <|> (NE.:| []) <$> field "studies" (NE.head . Person2.education)) pepe2 :: Person2 pepe2 = Person2 "Pepe" 38 ["2 Edward Square", "La Mar 10"] Nothing - (PhD "Computer Science") + [PhD "Computer Science", Degree "Engineering" ] -- Person2 can be encoded in multiple ways, so the canonic encoding includes all ways +-- >>> import qualified Data.ByteString.Lazy.Char8 as B +-- >>> import Data.Aeson.Encode.Pretty +-- >>> B.putStrLn $ encodePretty $ encodeTo (theSchema @Person2) pepe2 -- { -- "#1": { -- "education": { diff --git a/schemas.cabal b/schemas.cabal --- a/schemas.cabal +++ b/schemas.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: schemas -version: 0.2.0.2 +version: 0.2.0.3 synopsis: schema guided serialization description: Schemas is a Haskell library for serializing and deserializing data in JSON. diff --git a/src/Schemas/Class.hs b/src/Schemas/Class.hs --- a/src/Schemas/Class.hs +++ b/src/Schemas/Class.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} @@ -159,7 +160,7 @@ -- | Attempt to encode to the target schema using the default schema. -- First encodes using the default schema, then computes a coercion -- applying 'isSubtypeOf', and then applies the coercion to the encoded data. -encodeTo :: HasSchema a => Schema -> Maybe (a -> Value) +encodeTo :: HasSchema a => Schema -> Either [(Trace, Mismatch)] (a -> Value) encodeTo = encodeToWith schema -- | Encode a value into a finite representation by enforcing a max depth diff --git a/src/Schemas/Internal.hs b/src/Schemas/Internal.hs --- a/src/Schemas/Internal.hs +++ b/src/Schemas/Internal.hs @@ -26,11 +26,12 @@ import Data.Functor.Compose import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Semigroup -import Data.Text (Text, pack) +import Data.Text (Text, pack, unpack) import Data.Tuple import Data.Vector (Vector) import qualified Data.Vector as V @@ -46,7 +47,7 @@ -- for composition. -- -- * introduction forms: 'record', 'enum', 'schema' --- * operations: 'encodeTo', 'decodeFrom', 'extractSchema' +-- * operations: 'encodeToWith', 'decodeFrom', 'extractSchema' -- * composition: 'dimap', 'union', 'stringMap', 'liftPrism' -- data TypedSchemaFlex from a where @@ -64,6 +65,10 @@ 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 + -- | @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) @@ -216,7 +221,7 @@ -> RecordFields from (Maybe a) optFieldWith schema n = RecordFields $ liftAlt (OptionalAp n schema Nothing) --- | The most general introduction form for optional fields +-- | The most general introduction form for optional alts optFieldGeneral :: forall a from . TypedSchemaFlex from a @@ -322,10 +327,12 @@ -- --------------------------------------------------------------------------------------- -- Encoding to JSON +type E = [(Trace, Mismatch)] + -- | Given a value and its typed schema, produce a JSON record using the 'RecordField's encodeWith :: TypedSchemaFlex from a -> from -> Value -- TODO Better error messages to help debug partial schemas ? -encodeWith sc = either (throw . AllAlternativesFailed) id . runExcept . go sc where +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) @@ -340,24 +347,98 @@ let results = partitionEithers $ nonDet $ fmap (runExcept . sequenceA) alternatives case results of - (_, NE.nonEmpty -> Just fields') -> pure $ encodeAlternatives $ fmap + (_, NE.nonEmpty -> Just alts') -> pure $ encodeAlternatives $ fmap (A.Object . fromList . catMaybes) - fields' + alts' (ee, _) -> throwE (concat ee) where extractField b RequiredAp {..} = Just . (fieldName, ) <$> go fieldTypedSchema b `catchE` \mm -> - throwE [InvalidRecordField fieldName mm] + throwE [InvalidRecordField fieldName (map ([],) mm)] extractField b OptionalAp {..} = (Just . (fieldName, ) <$> go fieldTypedSchema b) `catchE` \_ -> pure Nothing -encodeToWith :: TypedSchema a -> Schema -> Maybe (a -> Value) -encodeToWith sc target = case isSubtypeOf (extractValidators sc) (extractSchema sc) target of - Right cast -> Just $ cast . encodeWith sc - _ -> Nothing +encodeToWith :: TypedSchemaFlex from a -> Schema -> Either E (from -> Value) +encodeToWith sc target = + (\m -> either (throw . AllAlternativesFailed) id . runExcept . m) + <$> runExcept (go [] sc target) + where + failWith ctx m = throwE [(reverse ctx, m)] + go + :: 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') + | n == n' = pure $ pure . fromf + | otherwise = failWith ctx (PrimMismatch n n') + go ctx (TArray sc _ fromf) (Array t) = do + f <- go ("[]" : ctx) sc t + return $ A.Array <.> traverse f . fromf + go ctx (TMap sc _ fromf) (StringMap t) = do + f <- go ("Map" : ctx) sc t + return $ A.Object <.> traverse f . fromf + 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 + 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 + 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 + (\alt -> + A.Object + . fromList + . (mapMaybe (sequenceOf _2)) + <$> 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) + + -- -------------------------------------------------------------------------- -- Decoding @@ -384,7 +465,7 @@ 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 fields ) from = runAlt f (getRecordFields fields) + go (RecordSchema alts ) from = runAlt f (getRecordFields alts) where f :: RecordField from b -> Except [DecodeError] b f RequiredAp{..} = go fieldTypedSchema from @@ -415,18 +496,18 @@ go ctx (RecordSchema rec) o@A.Object{} = do let alts = decodeAlternatives o asum $ concatMap - (\(A.Object fields, _encodedPath) -> - getCompose $ runAlt (Compose . (: []) . f fields) (getRecordFields rec) + (\(A.Object alts, _encodedPath) -> + getCompose $ runAlt (Compose . (: []) . f alts) (getRecordFields rec) ) alts where f :: A.Object -> RecordField from a -> Except [(Trace, DecodeError)] a - f fields (RequiredAp n sc) = case Map.lookup n fields of + 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' [] +-- TArray _ tof' _ -> pure $ tof' [] _ -> failWith ctx (MissingRecordField n) - f fields OptionalAp {..} = case Map.lookup fieldName fields of + f alts OptionalAp {..} = case Map.lookup fieldName alts of Just v -> go (fieldName : ctx) fieldTypedSchema v Nothing -> pure fieldDefValue @@ -460,5 +541,5 @@ (<.>) :: Functor f => (b -> c) -> (a -> f b) -> a -> f c f <.> g = fmap f . g -infixr 9 <.> +infixr 8 <.> diff --git a/src/Schemas/Untyped.hs b/src/Schemas/Untyped.hs --- a/src/Schemas/Untyped.hs +++ b/src/Schemas/Untyped.hs @@ -34,6 +34,9 @@ import Prelude hiding (lookup) import Text.Read +-- import Debug.Pretty.Simple + + -- Schemas -- -------------------------------------------------------------------------------- @@ -64,8 +67,12 @@ { fieldSchema :: Schema , isRequired :: Bool -- ^ defaults to True } - deriving (Eq, Generic, Show) + deriving (Eq, Generic) +instance Show Field where + 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 fieldSchemaL f Field{..} = Field <$> f fieldSchema <*> pure isRequired @@ -145,7 +152,7 @@ = MissingRecordField { name :: Text } | MissingEnumChoices { choices :: NonEmpty Text } | OptionalRecordField { name :: Text } - | InvalidRecordField { name :: Text, mismatches :: [Mismatch] } + | InvalidRecordField { name :: Text, mismatches :: [(Trace, Mismatch)] } | InvalidEnumValue { given :: Text, options :: NonEmpty Text} | InvalidConstructor { name :: Text} | InvalidUnionValue { contents :: Value} @@ -154,9 +161,11 @@ | EmptyAllOf | PrimValidatorMissing { name :: Text } | PrimError {name, primError :: Text} + | PrimMismatch {have, want :: Text} | InvalidChoice{choiceNumber :: Int} | TryFailed { name :: Text } - | AllAlternativesFailed { mismatches :: [Mismatch]} + | AllAlternativesFailed { mismatches :: [(Trace,Mismatch)]} + | NoMatches deriving (Eq, Show, Typeable) instance Exception Mismatch @@ -220,13 +229,14 @@ -- 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 - unless (a == b) $ failWith ctx (PrimError a b) + unless (a == b) $ failWith ctx (PrimMismatch b a) pure id go ctx (Array a) (Array b) = do f <- go ("[]" : ctx) a b @@ -234,7 +244,6 @@ go ctx (StringMap a) (StringMap b) = do f <- go ("Map" : ctx) a b pure $ over (_Object . traverse) f - go _tx (Array a) b | a == b = pure (A.Array . fromList . (: [])) go ctx (Enum opts) (Enum opts') = case NE.nonEmpty $ NE.filter (`notElem` opts) opts' of Nothing -> pure id @@ -280,6 +289,9 @@ (\(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 + pure (A.Array . fromList . (: []) . f) go _tx a b | a == b = pure id go ctx a b = failWith ctx (SchemaMismatch a b) diff --git a/test/Generators.hs b/test/Generators.hs --- a/test/Generators.hs +++ b/test/Generators.hs @@ -61,9 +61,9 @@ genSchema n = frequency [ (10,) $ Record <$> do nfields <- choose (1,2) - fieldArgs <- replicateM nfields (scale (`div` 2) arbitrary) + fieldArgs <- replicateM nfields (scale (`div` succ nfields) arbitrary) return $ fromList (zipWith (\n (sc,a) -> (n, Field sc a)) fieldNames fieldArgs) - , (10,) $ Array <$> scale(`div`2) arbitrary + , (10,) $ Array <$> scale(`div` 4) arbitrary , (10,) $ Enum <$> do n <- choose (1,2) return $ fromList $ take n ["Enum1", "Enum2"] @@ -71,7 +71,7 @@ , (1,) $ OneOf . fromList <$> listOf1 (genSchema (n`div`10)) , (5,) $ review _Union <$> do nconstructors <- choose (1,2) - args <- replicateM nconstructors (genSchema (n`div`nconstructors)) + args <- replicateM nconstructors (genSchema (n`div` succ nconstructors)) return $ fromList $ zip constructorNames args , (50,) $ genSchema 0 ] diff --git a/test/SchemasSpec.hs b/test/SchemasSpec.hs --- a/test/SchemasSpec.hs +++ b/test/SchemasSpec.hs @@ -13,25 +13,42 @@ 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 () main :: IO () -main = hspec spec +main = hspecWith defaultConfig{configQuickCheckMaxSuccess = Just 10000} spec spec :: Spec spec = do - describe "encoding" $ do + describe "encode" $ do prop "is the inverse of decoding" $ \(sc :: Schema) -> decode (encode sc) == Right sc + describe "encodeTo" $ do + it "laziness delivers" $ do + evaluate (fromRight undefined (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record [makeField "bottom" prim True])) (Nothing :: Maybe Bool)) + `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 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) -> @@ -81,25 +98,39 @@ prop "finite(schema @Schema) is a supertype of (schema @Schema)" $ \(SmallNatural n) -> theSchema @Schema `shouldBeSubtypeOf` finite n (theSchema @Schema) describe "Person" $ do - it "decode is the inverse of encode (applicative)" $ 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 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 it "Person2 < Person" $ do theSchema @Person2 `shouldBeSubtypeOf` theSchema @Person it "pepe2 `as` Person" $ do let encoder = encodeTo (theSchema @Person) - encoder `shouldSatisfy` isJust - decode (fromJust encoder pepe2) `shouldBe` Right pepe + 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 + fromJust decoder (encode pepe) `shouldBe` Right pepe2{Person2.education = [Person.studies pepe]} it "Person < Person2" $ do theSchema @Person `shouldBeSubtypeOf` theSchema @Person2 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 + +encodeToSpec tgt = encodeToWithSpec schema tgt + shouldBeSubtypeOf :: Schema -> Schema -> Expectation shouldBeSubtypeOf a b = case isSubtypeOf primValidators a b of Right _ -> pure () @@ -122,6 +153,11 @@ constructor' :: a -> b -> (a, b) constructor' n t = (n, t) +prim :: Schema prim = Prim "A" +primValidators :: Validators primValidators = validatorsFor @(Schema, Double, Int, Bool) + +finiteCornerCase :: Schema +finiteCornerCase = AllOf [ Array $ Prim "A"]