schemas 0.2.0.2 → 0.2.0.3

raw patch · 8 files changed

+175/−37 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +3/−0
• example/Person2.hs +8/−3
• schemas.cabal +1/−1
• src/Schemas/Class.hs +2/−1
• src/Schemas/Internal.hs +99/−18
• src/Schemas/Untyped.hs +17/−5
• test/Generators.hs +3/−3
• test/SchemasSpec.hs +42/−6

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

@@ -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": {

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

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

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

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

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

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