schema 0.0.2 → 0.0.3
raw patch · 9 files changed
+505/−154 lines, 9 filesdep +ansi-wl-pprintdep +bytestringdep +casingdep −msgpack-binary
Dependencies added: ansi-wl-pprint, bytestring, casing, data-fix, split, transformers-compat
Dependencies removed: msgpack-binary
Files
- schema.cabal +16/−5
- src/Data/Schema.hs +9/−42
- src/Data/Schema/Builder.hs +93/−0
- src/Data/Schema/C.hs +197/−0
- src/Data/Schema/Deinline.hs +19/−0
- src/Data/Schema/Pretty.hs +24/−0
- src/Data/Schema/Type.hs +67/−0
- test/Data/Schema/PrettySpec.hs +80/−0
- test/Data/SchemaSpec.hs +0/−107
schema.cabal view
@@ -1,12 +1,12 @@ name: schema-version: 0.0.2+version: 0.0.3 synopsis: Encoding-independent schemas for Haskell data types. homepage: https://toktok.github.io/ license: GPL-3 license-file: LICENSE author: Iphigenia Df <iphydf@gmail.com> maintainer: Iphigenia Df <iphydf@gmail.com>-copyright: Copyright (c) 2016-2018, Iphigenia Df+copyright: Copyright (c) 2016-2021, Iphigenia Df category: Data stability: Experimental cabal-version: >= 1.10@@ -26,8 +26,18 @@ -Wall exposed-modules: Data.Schema+ Data.Schema.Builder+ Data.Schema.C+ Data.Schema.Deinline+ Data.Schema.Pretty+ Data.Schema.Type build-depends: base < 5+ , ansi-wl-pprint+ , casing+ , data-fix+ , split+ , transformers-compat test-suite testsuite type: exitcode-stdio-1.0@@ -35,14 +45,15 @@ hs-source-dirs: test main-is: testsuite.hs other-modules:- Data.SchemaSpec+ Data.Schema.PrettySpec ghc-options: -Wall- -fno-warn-unused-imports+ build-tool-depends:+ hspec-discover:hspec-discover build-depends: base < 5 , QuickCheck- , msgpack-binary+ , bytestring , groom , hspec , schema
src/Data/Schema.hs view
@@ -1,43 +1,10 @@-{-# LANGUAGE FlexibleInstances #-}-module Data.Schema where--import Data.Proxy (Proxy)---data Field = Field- { fieldName :: String- , fieldType :: Type- }- deriving (Eq, Show, Read)--data Schema- = SchemaRecord [Field]- | SchemaInt- | SchemaDouble- | SchemaString- deriving (Eq, Show, Read)---data Type = Type- { typeName :: String- , typeSchema :: Schema- }- deriving (Eq, Show, Read)---class HasSchema a where- schema :: Proxy a -> Type---instance HasSchema Schema where- schema = error "TODO(robinlinden): define schema for Schema"---instance HasSchema Int where- schema _ = Type "Int" SchemaInt--instance HasSchema Double where- schema _ = Type "Double" SchemaDouble+module Data.Schema+ ( SchemaF (..)+ , Schema+ , Type (..)+ , Builder (..)+ , ToSchema (..)+ ) where -instance HasSchema String where- schema _ = Type "String" SchemaString+import Data.Schema.Builder (Builder (..), ToSchema (..))+import Data.Schema.Type (Schema, SchemaF (..), Type (..))
+ src/Data/Schema/Builder.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+module Data.Schema.Builder+ ( Builder (..)+ , ToSchema (..)+ , atom+ ) where++import Control.Applicative (liftA2)+import Data.Fix (Fix (..))+import Data.Schema.Type (Schema, SchemaF (..), Type (..), prodType)+import GHC.Generics+++data Builder a = Builder+ { zero :: a+ , getSchema :: Schema+ }+ deriving (Read, Show)++atom :: Type -> a -> Builder a+atom ty z = Builder z (Fix (Atom ty))++instance Semigroup (Builder a) where+ Builder x l <> Builder _ r = Builder x (l <> r)+instance Functor Builder where+ fmap f (Builder x s) = Builder (f x) s+instance Applicative Builder where+ pure x = Builder x (Fix Empty)+ Builder f l <*> Builder x r = Builder (f x) (prodType l r)+++class GToSchema f where+ gToSchema :: Builder (f a)+++class ToSchema a where+ toSchema :: Builder a++ default toSchema :: (Generic a, GToSchema (Rep a)) => Builder a+ toSchema = to <$> gToSchema++instance ToSchema a => ToSchema [a] where+ toSchema = Builder [v] (Fix (List s))+ where+ Builder v s = toSchema++instance GToSchema U1 where+ gToSchema = Builder U1 (Fix Empty)++instance (GToSchema a, GToSchema b) => GToSchema (a :*: b) where+ gToSchema = liftA2 (:*:) gToSchema gToSchema++instance (GToSchema a, GToSchema b) => GToSchema (a :+: b) where+ gToSchema = (L1 <$> gToSchema) <> (R1 <$> gToSchema)++instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where+ gToSchema =+ M1 <$> addDatatypeName+ (moduleName (undefined :: D1 d f a))+ (datatypeName (undefined :: D1 d f a))+ gToSchema+ where+ addDatatypeName :: String -> String -> Builder a -> Builder a+ addDatatypeName mName dName (Builder x (Fix (Sum Nothing cs))) =+ Builder x . Fix . Sum (Just (mName, dName)) $ cs+ addDatatypeName _ _ s = s++instance (Constructor c, GToSchema f) => GToSchema (C1 c f) where+ gToSchema = M1 <$> addConName (conName (undefined :: C1 c f a)) gToSchema+ where+ addConName :: String -> Builder a -> Builder a+ addConName name (Builder x (Fix Empty)) =+ Builder x . Fix . Atom . TyName $ name+ addConName name (Builder x s) =+ Builder x . Fix . Sum Nothing . (:[]) . Fix . Con name $ s++instance (Selector s, GToSchema f) => GToSchema (S1 s f) where+ gToSchema = M1 <$> addSelName (selName (undefined :: S1 s f a)) gToSchema+ where+ addSelName :: String -> Builder a -> Builder a+ addSelName "" b = b+ addSelName name (Builder x s) = Builder x . Fix . Field name $ s++instance GToSchema a => GToSchema (M1 t c a) where+ gToSchema = M1 <$> gToSchema++instance ToSchema a => GToSchema (K1 i a) where+ gToSchema = K1 <$> toSchema
+ src/Data/Schema/C.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE LambdaCase #-}+module Data.Schema.C where++import Control.Arrow ((&&&))+import qualified Data.Char as Char+import Data.Fix (Fix (..), foldFix)+import Data.List.Split as List+import Data.Schema (Schema, SchemaF (..), Type (..))+import Prelude hiding ((<$>))+import qualified Text.Casing as Casing+import Text.PrettyPrint.ANSI.Leijen++genC :: Schema -> Doc+genC (Fix (Sum (Just (mName, dName)) cons)) =+ vsep+ . punctuate line+ . map (uncurry genDatatype . flattenFields ns prefix)+ $ cons+ where+ ns = namespaceFor (List.splitOn "." mName)+ prefix = dName <> "_"+genC s = error $ show s++namespaceFor :: [String] -> String+namespaceFor [] = ""+namespaceFor [ns, "Types", _] = ns <> "_"+namespaceFor (_:parts) = namespaceFor parts++data StructField = StructField+ { sfField :: Doc+ , sfType :: Type+ }+ deriving (Show)++data StructName = StructName+ { snType :: Doc+ , snFun :: Doc+ }+ deriving (Show)++flattenFields :: String -> String -> Schema -> (StructName, [StructField])+flattenFields ns prefix = conName . unFix &&& foldFix go+ where+ go (Atom ty) = [StructField empty ty]+ go (Sum (Just (_, ty)) _) = [StructField empty $ tyName ns ty]++ go (Field name tys) = map (\ty -> ty{sfField = fieldName name}) tys+ go (Con _ tys) = tys+ go (Prod fields) = concat fields+ go (Sum Nothing _) = []+ go Empty = []+ go Module{} = []+ go Schema{} = []+ go List{} = []++ conName (Con name _) = StructName+ { snType = text $ toCName name+ , snFun = text $ map Char.toLower $ toCName name <> "_"+ }+ conName _ = StructName empty empty++ -- | @TypeName -> Namespace_Prefix_Type_Name@+ toCName :: String -> String+ toCName name = ns <> prefix <> toCamelSnake name++genDatatype :: StructName -> [StructField] -> Doc+genDatatype sName fields =+ genHeader sName fields </> line <>+ genSource sName fields++genHeader :: StructName -> [StructField] -> Doc+genHeader sName fields =+ text "// events.h" </>+ genTypedef sName </>+ genGetterDecls sName fields++genSource :: StructName -> [StructField] -> Doc+genSource sName fields =+ text "// events.c" </>+ genStruct sName fields </> line <>+ (vcat . punctuate line . map (\field ->+ genGetterDefn sName field </>+ genSetterDefn sName field) $ fields)++genTypedef :: StructName -> Doc+genTypedef (StructName sName _) =+ text "typedef struct" <+> sName <+> sName <> semi++-- | Generate the C struct definition.+genStruct :: StructName -> [StructField] -> Doc+genStruct (StructName sName _) fields =+ text "struct" <+> sName <+> braces (line <>+ indent 4 (vcat (map ((<> semi) . go) fields))+ <> line) <> semi+ where+ go (StructField f TyBool) = text "bool" <+> f+ go (StructField f TyWord8) = text "uint8_t" <+> f+ go (StructField f TyWord16) = text "uint16_t" <+> f+ go (StructField f TyWord32) = text "uint32_t" <+> f+ go (StructField f TyWord64) = text "uint64_t" <+> f+ go (StructField f (TyName s)) = text s <+> f+ go (StructField f (TyFixedBin s)) =+ text "uint8_t" <+> f <> brackets (int s)+ go (StructField f TyBin) =+ text "uint8_t *" <> f <> semi </>+ text "uint32_t " <> f <> text "_size"++eventParam :: Doc -> Doc -> Doc -> Doc+eventParam qual sName params =+ parens (line <> indent 4 (qual <> sName <+> text "*event" <> params))++getterDecl :: Doc -> Doc -> String -> Doc -> Doc+getterDecl sName fName ty f =+ text ty <> fName <> text "get_" <> f <> eventParam (text "const ") sName empty++setterDecl :: Doc -> Doc -> String -> Doc -> Doc -> Doc+setterDecl sName fName ty f params =+ text "static void" <+> fName <> text "set_" <> f <> eventParam empty sName (text (", " <> ty <> "value") <> params)++getterDeclFor :: (String -> Doc -> Doc) -> StructField -> Doc+getterDeclFor decl = \case+ (StructField f TyBool) -> decl "bool " f+ (StructField f TyWord8) -> decl "uint8_t " f+ (StructField f TyWord16) -> decl "uint16_t " f+ (StructField f TyWord32) -> decl "uint32_t " f+ (StructField f TyWord64) -> decl "uint64_t " f+ (StructField f (TyName s)) -> decl (s <> " ") f+ (StructField f TyFixedBin{}) -> decl "const uint8_t *" f+ (StructField f TyBin) ->+ decl "const uint8_t *" f <> semi </>+ decl "uint32_t " (f <> text "_size")++genGetterDecls :: StructName -> [StructField] -> Doc+genGetterDecls (StructName sName fName) fields =+ vcat (map ((<> semi) . getterDeclFor decl) fields)+ where+ decl = getterDecl sName fName++genGetterDefn :: StructName -> StructField -> Doc+genGetterDefn (StructName sName fName) = getterDeclFor defn+ where+ defn ty f = getterDecl sName fName ty f </> braces+ (line <> indent 4 (text "return event->" <> f <> semi) <> line)++genSetterDefn :: StructName -> StructField -> Doc+genSetterDefn (StructName sName fName) = go+ where+ defn params body ty field = setterDecl sName fName ty field params </> braces+ (line <> indent 4 (body field) <> line)++ setValue field = text "event->" <> field <> text " = value" <> semi+ simpleDefn = defn empty setValue++ setFixedBin n field =+ text "memcpy" <> parens (text "event->" <> field <> text ", value, " <> int n) <> semi+ setBin field =+ text "assert(event != nullptr);" </>+ line </>+ text "if (event->" <> field <> text " != nullptr)" <+> braces (line <>+ indent 4 (+ text "free(event->" <> field <> text ");" </>+ text "event->" <> field <> text " = nullptr;" </>+ text "event->" <> field <> text "_size = 0;"+ ) <> line) </>+ line </>+ text "event->" <> field <> text " = (uint8_t *)malloc(size);" </>+ line <>+ text "if (event->" <> field <> text " == nullptr)" <+> braces (line <>+ indent 4 (+ text "return false;"+ ) <> line) </>+ line </>+ text "memcpy" <> parens (text "event->" <> field <> text ", value, size") <> semi </>+ text "event->" <> field <> text "_size = size;" </>+ text "return true;"++ go (StructField field TyBool) = simpleDefn "bool " field+ go (StructField field TyWord8) = simpleDefn "uint8_t " field+ go (StructField field TyWord16) = simpleDefn "uint16_t " field+ go (StructField field TyWord32) = simpleDefn "uint32_t " field+ go (StructField field TyWord64) = simpleDefn "uint64_t " field+ go (StructField field (TyName s)) = simpleDefn (s <> " ") field+ go (StructField field (TyFixedBin n)) =+ defn empty (setFixedBin n) "const uint8_t *" field+ go (StructField field TyBin) =+ defn (text ", uint32_t size") setBin "const uint8_t *" field++-- | @fieldName' -> field_name@+fieldName :: String -> Doc+fieldName = text . filter (/= '\'') . Casing.toQuietSnake . Casing.fromHumps++tyName :: String -> String -> Type+tyName ns = TyName . (ns <>) . toCamelSnake++-- | @TypeName -> Type_Name@+toCamelSnake :: String -> String+toCamelSnake = Casing.toSnake . Casing.fromHumps
+ src/Data/Schema/Deinline.hs view
@@ -0,0 +1,19 @@+module Data.Schema.Deinline (deinline) where++import Control.Arrow (first)+import Data.Fix (Fix (..), foldFix)+import Data.List (nub)+import Data.Schema (Schema, SchemaF (..), Type (..))++deinline :: Schema -> Schema+deinline = fst . foldFix getTypes++getTypes :: SchemaF (Schema, [Schema]) -> (Schema, [Schema])+getTypes (Atom ty) = (Fix . Atom $ ty, [])+getTypes (Sum dt@(Just (_, ty)) cons) = (Fix . Atom . TyName $ ty, Fix (Sum dt (map fst cons)) : concatMap snd cons)+getTypes (Prod fields) = (Fix . Prod . map fst $ fields, concatMap snd fields)+getTypes (Field name ty) = first (Fix . Field name) ty+getTypes (Con name ty) = first (Fix . Con name) ty+getTypes (List ty) = first (Fix . List) ty+getTypes (Schema mods) = (Fix . Schema . nub . concatMap snd $ mods, [])+getTypes x = error $ "unhandled: " <> show x
+ src/Data/Schema/Pretty.hs view
@@ -0,0 +1,24 @@+module Data.Schema.Pretty (ppSchema) where++import Data.Fix (foldFix)+import Data.Schema (Schema, SchemaF (..))+import Prelude hiding ((<$>))+import Text.PrettyPrint.ANSI.Leijen++ppSchema :: Schema -> Doc+ppSchema = (<> line) . foldFix go++go :: SchemaF Doc -> Doc+go (Atom ty) = text $ show ty+go (Field name ty) = text name <+> text "::" <+> ty+go (List ty) = text "repeated" <+> ty+go (Con name ty) = text name <+> equals <+> ty+go (Prod fields) = braces (line <> indent 2 (vcat fields) <> line)+go (Sum Nothing cons) = vcat cons+go (Sum (Just (m, ty)) cons) =+ text ("type " <> m <> "." <> ty) <+> braces (+ line <> indent 2 (vcat cons)+ <> line)+go (Module name ss) = text "module" <+> text name <$> vcat ss+go (Schema mods) = text "schema 1.0;" <$> line <> vcat (punctuate line mods)+go Empty = text "<empty>"
+ src/Data/Schema/Type.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+module Data.Schema.Type+ ( SchemaF (..)+ , Schema+ , Type (..)+ , sumType+ , prodType+ ) where++import Control.Applicative ((<|>))+import Data.Fix (Fix (..))+import Data.Functor.Classes (Eq1, Read1, Show1)+import Data.Functor.Classes.Generic (FunctorClassesDefault (..))+import GHC.Generics (Generic, Generic1)+++data Type+ = TyBool+ | TyWord8+ | TyWord16+ | TyWord32+ | TyWord64+ | TyBin+ | TyFixedBin Int+ | TyName String+ deriving (Show, Read, Eq)++type DatatypeName = (String, String)++data SchemaF a+ = Empty+ | Atom Type+ | List a++ | Prod [a]+ | Field String a++ | Sum (Maybe DatatypeName) [a]+ | Con String a++ | Module String [a]+ | Schema [a]+ deriving (Show, Read, Eq, Generic, Generic1, Functor, Foldable, Traversable)+ deriving (Show1, Read1, Eq1) via FunctorClassesDefault SchemaF++type Schema = Fix SchemaF++instance Semigroup Schema where+ (<>) = sumType++sumType :: Schema -> Schema -> Schema+sumType (Fix (Sum da a)) (Fix (Sum db b)) = Fix $ Sum (da <|> db) (a ++ b)+sumType (Fix (Sum da a)) b = Fix $ Sum da (a ++ [b])+sumType a (Fix (Sum db b)) = Fix $ Sum db (a : b)+sumType a b = Fix $ Sum Nothing [a, b]++prodType :: Schema -> Schema -> Schema+prodType (Fix (Prod a)) (Fix (Prod b)) = Fix $ Prod (a ++ b)+prodType (Fix (Prod a)) b = Fix $ Prod (a ++ [b])+prodType a (Fix (Prod b)) = Fix $ Prod (a : b)+prodType a b = Fix $ Prod [a, b]
+ test/Data/Schema/PrettySpec.hs view
@@ -0,0 +1,80 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Data.Schema.PrettySpec where++import GHC.Generics (Generic)+import Test.Hspec++import qualified Data.ByteString as BS+import Data.Proxy (Proxy (..))+import Data.Schema+import Data.Schema.Builder (atom)+import Data.Schema.Pretty (ppSchema)+import Data.Word (Word16, Word32, Word64)+import GHC.TypeNats (KnownNat, Nat, natVal)+++newtype FixedByteString (size :: Nat) = FixedByteString BS.ByteString+ deriving (Ord, Eq, Read, Show, Generic)+instance KnownNat size => ToSchema (FixedByteString (size :: Nat)) where+ toSchema = atom (TyFixedBin (fromIntegral $ natVal (Proxy :: Proxy size))) (FixedByteString BS.empty)++instance ToSchema BS.ByteString where+ toSchema = atom TyBin BS.empty+instance ToSchema Word16 where+ toSchema = atom TyWord16 0+instance ToSchema Word32 where+ toSchema = atom TyWord32 0+instance ToSchema Word64 where+ toSchema = atom TyWord64 0+instance ToSchema Bool where+ toSchema = atom TyBool False++instance ToSchema Int where+ toSchema = atom TyWord32 0+instance ToSchema Double where+ toSchema = atom (TyName "double") 0+instance ToSchema String where+ toSchema = atom (TyName "string") ""++--------------------------------------------------------------------------------+-- Version 1 of the protocol.+--+data MyRecordV1 = MyRecordV1+ { recordField1V1 :: Int+ , recordField2V1 :: Double+ , recordField3V1 :: String+ , someWord32V1 :: Word32+ , publicKeyV1 :: FixedByteString 32+ , messageV1 :: BS.ByteString+ }+ deriving (Eq, Show, Read, Generic)++instance ToSchema MyRecordV1++myRecordV1 :: Schema+myRecordV1 = getSchema (toSchema :: Builder MyRecordV1)+++spec :: Spec+spec =+ describe "ppSchema" $ do+ it "prints a human-readable form" $ do+ show (ppSchema myRecordV1) `shouldBe` unlines+ [ "type Data.Schema.PrettySpec.MyRecordV1 {"+ , " MyRecordV1 = {"+ , " recordField1V1 :: TyWord32"+ , " recordField2V1 :: TyName \"double\""+ , " recordField3V1 :: TyName \"string\""+ , " someWord32V1 :: TyWord32"+ , " publicKeyV1 :: TyFixedBin 32"+ , " messageV1 :: TyBin"+ , " }"+ , "}"+ ]
− test/Data/SchemaSpec.hs
@@ -1,107 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Data.SchemaSpec (spec) where--import Control.Applicative ((<$>), (<*>))-import Control.Monad (when)-import Data.Proxy (Proxy (..))-import Debug.Trace (trace)-import GHC.Generics (Generic)-import Test.Hspec-import Test.QuickCheck-import Text.Groom (groom)--import Data.MessagePack (MessagePack (..), Object (..))-import Data.Schema------------------------------------------------------------------------------------- Version 1 of the protocol.----data MyRecordV1 = MyRecordV1- { recordField1V1 :: Int- , recordField2V1 :: Double- , recordField3V1 :: String- }- deriving (Eq, Show, Read, Generic)--instance MessagePack MyRecordV1-instance Arbitrary MyRecordV1 where- arbitrary = MyRecordV1- <$> arbitrary- <*> arbitrary- <*> arbitrary---instance HasSchema MyRecordV1 where- schema p = Type- { typeName = "MyRecord"- , typeSchema = SchemaRecord- [ Field "recordField1" $ schema $ recordField1V1 <$> p- , Field "recordField2" $ schema $ recordField2V1 <$> p- , Field "recordField3" $ schema $ recordField3V1 <$> p- ]- }-------------------------------------------------------------------------------------- Version 2 of the protocol.------ This version has reordered the second and third field.----data MyRecordV2 = MyRecordV2- { recordField1V2 :: Int- , recordField3V2 :: String- , recordField2V2 :: Double- }- deriving (Eq, Show, Read, Generic)--instance MessagePack MyRecordV2-instance Arbitrary MyRecordV2 where- arbitrary = MyRecordV2- <$> arbitrary- <*> arbitrary- <*> arbitrary---instance HasSchema MyRecordV2 where- schema p = Type- { typeName = "MyRecord"- , typeSchema = SchemaRecord- [ Field "recordField1" $ schema $ recordField1V2 <$> p- -- Also reordered here so we know the order in the schema.- , Field "recordField3" $ schema $ recordField3V2 <$> p- , Field "recordField2" $ schema $ recordField2V2 <$> p- ]- }-------------------------------------------------------------------------------------- Implementation of schema loading goes here:----fromObjectWithSchema :: (MessagePack a, HasSchema a) => Type -> Type -> Object -> a-fromObjectWithSchema srcType tgtType obj =- trace ("Loading object: " ++ groom obj) $- trace ("Source schema: " ++ groom srcType) $- trace ("Target schema: " ++ groom tgtType) $- error "unimplemented: fromObjectWithSchema"---spec :: Spec-spec =- describe "msgpack formats" $- it "can be translated from v1 to v2 and back" $- property $ \(v1 :: MyRecordV1) ->- let- -- Forward:- obj1 = toObject v1- scm1 = schema (Proxy :: Proxy MyRecordV1)- v2 :: MyRecordV2- v2 = fromObjectWithSchema scm1 scm2 obj1- -- And back:- obj2 = toObject v2- scm2 = schema (Proxy :: Proxy MyRecordV2)- v1' :: MyRecordV1- v1' = fromObjectWithSchema scm2 scm1 obj2- in- when False $- v1' `shouldBe` v1