schematic 0.1.6.0 → 0.2.0.0

raw patch · 10 files changed

+581/−96 lines, 10 filesdep +containersdep +hjsonschemadep +mtldep ~singletonsPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, hjsonschema, mtl

Dependency ranges changed: singletons

API changes (from Hackage documentation)

Files

• ChangeLog.md +3/−0
• schematic.cabal +11/−2
• src/Data/Schematic.hs +21/−52
• src/Data/Schematic/JsonSchema.hs +75/−0
• src/Data/Schematic/Migration.hs +5/−8
• src/Data/Schematic/Schema.hs +144/−6
• src/Data/Schematic/Validation.hs +3/−1
• test/JsonSchemaSpec.hs +43/−0
• test/LensSpec.hs +273/−6
• test/SchemaSpec.hs +3/−21

@@ -1,5 +1,8 @@ # Revision history for schematic +## 0.2.0.0 -- 2017-09-26++Migratable is deprecated, migrations are now possible in an arbitrary monad.  ## 0.1.5.0 -- 2017-08-22 

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                schematic-version:             0.1.6.0+version:             0.2.0.0 synopsis:            JSON-biased spec and validation tool -- description: license:             BSD3@@ -18,6 +18,7 @@ library   exposed-modules:     Data.Schematic                      , Data.Schematic.Instances+                     , Data.Schematic.JsonSchema                      , Data.Schematic.Lens                      , Data.Schematic.Migration                      , Data.Schematic.Path@@ -31,6 +32,7 @@                      , DefaultSignatures                      , DeriveFunctor                      , DeriveFoldable+                     , DeriveTraversable                      , DeriveGeneric                      , DeriveDataTypeable                      , FlexibleContexts@@ -61,9 +63,12 @@   build-depends:       base >=4.9 && <4.10                      , bytestring                      , aeson >= 1+                     , containers+                     , hjsonschema+                     , mtl                      , regex-compat                      , scientific-                     , singletons+                     , singletons >= 2.2                      , smallcheck                      , smallcheck-series                      , tagged@@ -92,6 +97,7 @@                      , GADTs                      , KindSignatures                      , InstanceSigs+                     , LambdaCase                      , MultiParamTypeClasses                      , OverloadedLists                      , OverloadedStrings@@ -110,6 +116,8 @@                      , aeson >= 1                      , base >=4.9 && <4.10                      , bytestring+                     , containers+                     , hjsonschema                      , hspec >= 2.2.0                      , hspec-core                      , hspec-discover@@ -127,3 +135,4 @@                      , vinyl   other-modules:       SchemaSpec                      , LensSpec+                     , JsonSchemaSpec

@@ -2,23 +2,21 @@ {-# LANGUAGE AllowAmbiguousTypes #-}  module Data.Schematic-  ( module Data.Schematic.Schema+  ( module Data.Schematic.JsonSchema+  , module Data.Schematic.Schema   , module Data.Schematic.Lens   , module Data.Schematic.Migration   , module Data.Schematic.Utils   , decodeAndValidateJson   , parseAndValidateJson   , parseAndValidateJsonBy-  , parseAndValidateVersionedJson   , parseAndValidateTopVersionJson-  , decodeAndValidateVersionedJson   , parseAndValidateWithMList   , decodeAndValidateVersionedWithMList   , isValid   , isDecodingError   , isValidationError   , ParseResult(..)-  , Migratable   ) where  import Control.Monad.Validation@@ -26,6 +24,7 @@ import Data.Aeson.Types as J import Data.ByteString.Lazy as BL import Data.Functor.Identity+import Data.Schematic.JsonSchema import Data.Schematic.Lens import Data.Schematic.Migration import Data.Schematic.Schema@@ -76,44 +75,22 @@         Left em  -> ValidationError em         Right () -> Valid jsonRepr -class Migratable (revisions :: [(Revision, Schema)]) where-  mparse-    :: Sing revisions-    -> J.Value-    -> ParseResult (JsonRepr (Snd (Head revisions)))--instance-  {-# OVERLAPPING #-}-  ( TopLevel (Snd rev), SingI (Snd rev) )-  => Migratable '[rev] where-  mparse _ = parseAndValidateJson--instance {-# OVERLAPPABLE #-}-  ( Migratable (Tail revisions)-  , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))-  , SingI (Snd (Head revisions)))-  => Migratable revisions where-  mparse s v = case parseEither parseJSON v of-    Left _  ->-      migrate <$> (mparse (sTail s) v :: ParseResult (JsonRepr (Snd (Head (Tail revisions)))))-    Right x -> Valid x--parseAndValidateVersionedJson-  :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v))-  => proxy v-  -> J.Value-  -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))-parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v- parseAndValidateWithMList-  :: MList revisions+  :: Monad m+  => MList m revisions   -> J.Value-  -> ParseResult (JsonRepr (Head revisions))-parseAndValidateWithMList MNil v = parseAndValidateJson v+  -> m (ParseResult (JsonRepr (Head revisions)))+parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of-    Valid a           -> Valid a-    DecodingError _   -> f <$> parseAndValidateWithMList tl v-    ValidationError _ -> f <$> parseAndValidateWithMList tl v+    Valid a           -> pure $ Valid a+    DecodingError _   -> do+      pr <- parseAndValidateWithMList tl v+      let pr' = f <$> pr+      sequence pr'+    ValidationError _ -> do+      pr <- parseAndValidateWithMList tl v+      let pr' = f <$> pr+      sequence pr'  decodeAndValidateJson   :: forall schema@@ -124,24 +101,16 @@   Nothing -> DecodingError "malformed json"   Just x  -> parseAndValidateJson x -decodeAndValidateVersionedJson-  :: (Migratable (AllVersions versioned), SingI (AllVersions versioned))-  => proxy versioned-  -> BL.ByteString-  -> ParseResult (JsonRepr (Snd (Head (AllVersions versioned))))-decodeAndValidateVersionedJson vp bs = case decode bs of-  Nothing -> DecodingError "malformed json"-  Just x  -> parseAndValidateVersionedJson vp x- type family MapSnd (l :: [(a,k)]) = (r :: [k]) where   MapSnd '[] = '[]   MapSnd ( '(a, b) ': tl) = b ': MapSnd tl  decodeAndValidateVersionedWithMList-  :: proxy versioned-  -> MList (MapSnd (AllVersions versioned))+  :: Monad m+  => proxy versioned+  -> MList m (MapSnd (AllVersions versioned))   -> BL.ByteString-  -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))+  -> m (ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))) decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of-  Nothing -> DecodingError "malformed json"+  Nothing -> pure $ DecodingError "malformed json"   Just x  -> parseAndValidateWithMList mlist x

@@ -0,0 +1,75 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedLabels #-}++module Data.Schematic.JsonSchema+  ( toJsonSchema+  , toJsonSchema'+  ) where++import Control.Monad.State.Strict+import Data.Foldable+import Data.HashMap.Strict as H+import Data.List.NonEmpty+import Data.Schematic.Schema as S+import Data.Singletons+import Data.Text+import JSONSchema.Draft4.Schema as D4+import JSONSchema.Validator.Draft4 as D4+++draft4 :: Text+draft4 = "http://Jason-schema.org/draft-04/schema#"++-- FIXME: implement all this later+textConstraint :: DemotedTextConstraint -> State D4.Schema ()+textConstraint (DTEq _) = pure ()+textConstraint (DTLt _) = pure ()+textConstraint (DTLe _) = pure ()+textConstraint (DTGt _) = pure ()+textConstraint (DTGe _) = pure ()+textConstraint (DTRegex _) = pure ()+textConstraint (DTEnum _) = pure ()++numberConstraint :: DemotedNumberConstraint -> State D4.Schema ()+numberConstraint (DNLe _) = pure ()+numberConstraint (DNLt _) = pure ()+numberConstraint (DNGt _) = pure ()+numberConstraint (DNGe _) = pure ()+numberConstraint (DNEq _) = pure ()++arrayConstraint :: DemotedArrayConstraint -> State D4.Schema ()+arrayConstraint (DAEq _) = pure ()++toJsonSchema+  :: forall proxy schema+   . SingI schema+  => proxy (schema :: S.Schema)+  -> D4.Schema+toJsonSchema _ = (toJsonSchema' $ fromSing (sing :: Sing schema))+  { _schemaVersion = pure draft4 }++toJsonSchema'+  :: DemotedSchema+  -> D4.Schema+toJsonSchema' = \case+  DSchemaText tcs ->+    execState (traverse_ textConstraint tcs) $ emptySchema+      { _schemaType = pure $ TypeValidatorString D4.SchemaString }+  DSchemaNumber ncs ->+    execState (traverse_ numberConstraint ncs) $ emptySchema+      { _schemaType = pure $ TypeValidatorString D4.SchemaNumber }+  DSchemaBoolean -> emptySchema+      { _schemaType = pure $ TypeValidatorString D4.SchemaBoolean }+  DSchemaObject objs -> emptySchema+      { _schemaType = pure $ TypeValidatorString D4.SchemaObject+      , _schemaProperties = pure $ H.fromList $ (\(n,s) -> (n, toJsonSchema' s))+        <$> objs }+  DSchemaArray acs sch ->+    execState (traverse_ arrayConstraint acs) $ emptySchema+      { _schemaType = pure $ TypeValidatorString D4.SchemaArray+      , _schemaItems = pure $ ItemsArray [toJsonSchema' sch] }+  DSchemaNull -> emptySchema+      { _schemaType = pure $ TypeValidatorString D4.SchemaNull }+  DSchemaOptional sch -> emptySchema+      { _schemaOneOf = pure $ toJsonSchema' DSchemaNull :| [toJsonSchema' sch] }

@@ -99,9 +99,6 @@ type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where   TopVersion ( '(rh, sh) ': tl) = sh -class MigrateSchema (a :: Schema) (b :: Schema) where-  migrate :: JsonRepr a -> JsonRepr b- data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol  data instance Sing (a :: Action) where@@ -141,13 +138,13 @@     -> Sing (ms :: [Migration]) -- a bunch of migrations     -> Sing ('Versioned s ms) -data MList :: [Schema] -> Type where-  MNil :: (SingI s, TopLevel s) => MList '[s]+data MList :: (* -> *) -> [Schema] -> Type where+  MNil :: (Monad m, SingI s, TopLevel s) => MList m '[s]   (:&&)     :: (TopLevel s, SingI s)     => proxy s-    -> (JsonRepr h -> JsonRepr s)-    -> MList (h ': tl)-    -> MList (s ': h ': tl)+    -> (JsonRepr h -> m (JsonRepr s))+    -> MList m (h ': tl)+    -> MList m (s ': h ': tl)  infixr 7 :&&

@@ -22,14 +22,11 @@ import           Data.Vinyl hiding (Dict) import qualified Data.Vinyl.TypeLevel as V import           GHC.Generics (Generic)+import           GHC.TypeLits (SomeNat(..), SomeSymbol(..), someSymbolVal, someNatVal) import           Prelude as P import           Test.SmallCheck.Series  -type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where-  All c '[]       = ()-  All c (a ': as) = (c a, All c as)- type family CRepr (s :: Schema) :: Type where   CRepr ('SchemaText cs)  = TextConstraint   CRepr ('SchemaNumber cs) = NumberConstraint@@ -46,6 +43,51 @@   | TEnum [Symbol]   deriving (Generic) +instance SingKind TextConstraint where+  type DemoteRep TextConstraint = DemotedTextConstraint+  fromSing = \case+    STEq n -> withKnownNat n (DTEq $ natVal n)+    STLt n -> withKnownNat n (DTLt $ natVal n)+    STLe n -> withKnownNat n (DTLe $ natVal n)+    STGt n -> withKnownNat n (DTGt $ natVal n)+    STGe n -> withKnownNat n (DTGe $ natVal n)+    STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s)+    STEnum s -> let+      d :: Sing (s :: [Symbol]) -> [Text]+      d SNil              = []+      d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs+      in DTEnum $ d s+  toSing = \case+    DTEq n -> case someNatVal n of+      Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n))+      Nothing -> error "Negative singleton nat"+    DTLt n -> case someNatVal n of+      Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLt (SNat :: Sing n))+      Nothing -> error "Negative singleton nat"+    DTLe n -> case someNatVal n of+      Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLe (SNat :: Sing n))+      Nothing -> error "Negative singleton nat"+    DTGt n -> case someNatVal n of+      Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGt (SNat :: Sing n))+      Nothing -> error "Negative singleton nat"+    DTGe n -> case someNatVal n of+      Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGe (SNat :: Sing n))+      Nothing -> error "Negative singleton nat"+    DTRegex s -> case someSymbolVal (T.unpack s) of+      SomeSymbol (_ :: Proxy n) -> SomeSing (STRegex (SSym :: Sing n))+    DTEnum ss -> case toSing (T.unpack <$> ss) of+      SomeSing l -> SomeSing (STEnum l)++data DemotedTextConstraint+  = DTEq Integer+  | DTLt Integer+  | DTLe Integer+  | DTGt Integer+  | DTGe Integer+  | DTRegex Text+  | DTEnum [Text]+  deriving (Generic)+ data instance Sing (tc :: TextConstraint) where   STEq :: Sing n -> Sing ('TEq n)   STLt :: Sing n -> Sing ('TLt n)@@ -53,7 +95,7 @@   STGt :: Sing n -> Sing ('TGt n)   STGe :: Sing n -> Sing ('TGe n)   STRegex :: Sing s -> Sing ('TRegex s)-  STEnum :: All KnownSymbol ss => Sing ss -> Sing ('TEnum ss)+  STEnum :: Sing ss -> Sing ('TEnum ss)  instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing@@ -61,7 +103,7 @@ instance (KnownNat n) => SingI ('TLt n) where sing = STLt sing instance (KnownNat n) => SingI ('TLe n) where sing = STLe sing instance (KnownSymbol s, SingI s) => SingI ('TRegex s) where sing = STRegex sing-instance (All KnownSymbol ss, SingI ss) => SingI ('TEnum ss) where sing = STEnum sing+instance (SingI ss) => SingI ('TEnum ss) where sing = STEnum sing  instance Eq (Sing ('TEq n)) where _ == _ = True instance Eq (Sing ('TLt n)) where _ == _ = True@@ -79,6 +121,14 @@   | NEq Nat   deriving (Generic) +data DemotedNumberConstraint+  = DNLe Integer+  | DNLt Integer+  | DNGt Integer+  | DNGe Integer+  | DNEq Integer+  deriving (Generic)+ data instance Sing (nc :: NumberConstraint) where   SNEq :: Sing n -> Sing ('NEq n)   SNGt :: Sing n -> Sing ('NGt n)@@ -98,10 +148,39 @@ instance Eq (Sing ('NGt n)) where _ == _ = True instance Eq (Sing ('NGe n)) where _ == _ = True +instance SingKind NumberConstraint where+  type DemoteRep NumberConstraint = DemotedNumberConstraint+  fromSing = \case+    SNEq n -> withKnownNat n (DNEq $ natVal n)+    SNGt n -> withKnownNat n (DNGt $ natVal n)+    SNGe n -> withKnownNat n (DNGe $ natVal n)+    SNLt n -> withKnownNat n (DNLt $ natVal n)+    SNLe n -> withKnownNat n (DNLe $ natVal n)+  toSing = \case+    DNEq n -> case someNatVal n of+      Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNEq (SNat :: Sing n))+      Nothing -> error "Negative singleton nat"+    DNGt n -> case someNatVal n of+      Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGt (SNat :: Sing n))+      Nothing -> error "Negative singleton nat"+    DNGe n -> case someNatVal n of+      Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGe (SNat :: Sing n))+      Nothing -> error "Negative singleton nat"+    DNLt n -> case someNatVal n of+      Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLt (SNat :: Sing n))+      Nothing -> error "Negative singleton nat"+    DNLe n -> case someNatVal n of+      Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLe (SNat :: Sing n))+      Nothing -> error "Negative singleton nat"+ data ArrayConstraint   = AEq Nat   deriving (Generic) +data DemotedArrayConstraint+  = DAEq Integer+  deriving (Generic)+ data instance Sing (ac :: ArrayConstraint) where   SAEq :: Sing n -> Sing ('AEq n) @@ -109,8 +188,18 @@  instance Eq (Sing ('AEq n)) where _ == _ = True +instance SingKind ArrayConstraint where+  type DemoteRep ArrayConstraint = DemotedArrayConstraint+  fromSing = \case+    SAEq n -> withKnownNat n (DAEq $ natVal n)+  toSing = \case+    DAEq n -> case someNatVal n of+      Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAEq (SNat :: Sing n))+      Nothing -> error "Negative singleton nat"+ data Schema   = SchemaText [TextConstraint]+  | SchemaBoolean   | SchemaNumber [NumberConstraint]   | SchemaObject [(Symbol, Schema)]   | SchemaArray [ArrayConstraint] Schema@@ -118,9 +207,20 @@   | SchemaOptional Schema   deriving (Generic) +data DemotedSchema+  = DSchemaText [DemotedTextConstraint]+  | DSchemaNumber [DemotedNumberConstraint]+  | DSchemaBoolean+  | DSchemaObject [(Text, DemotedSchema)]+  | DSchemaArray [DemotedArrayConstraint] DemotedSchema+  | DSchemaNull+  | DSchemaOptional DemotedSchema+  deriving (Generic)+ data instance Sing (schema :: Schema) where   SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)   SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)+  SSchemaBoolean :: Sing 'SchemaBoolean   SSchemaArray :: Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)   SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)   SSchemaOptional :: Sing s -> Sing ('SchemaOptional s)@@ -132,6 +232,8 @@   sing = SSchemaNumber sing instance SingI 'SchemaNull where   sing = SSchemaNull+instance SingI 'SchemaBoolean where+  sing = SSchemaBoolean instance (SingI ac, SingI s) => SingI ('SchemaArray ac s) where   sing = SSchemaArray sing sing instance SingI stl => SingI ('SchemaObject stl) where@@ -142,10 +244,40 @@ instance Eq (Sing ('SchemaText cs)) where _ == _ = True instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True instance Eq (Sing 'SchemaNull) where _ == _ = True+instance Eq (Sing 'SchemaBoolean) where _ == _ = True instance Eq (Sing ('SchemaArray as s)) where _ == _ = True instance Eq (Sing ('SchemaObject cs)) where _ == _ = True instance Eq (Sing ('SchemaOptional s)) where _ == _ = True +instance SingKind Schema where+  type DemoteRep Schema = DemotedSchema+  fromSing = \case+    SSchemaText cs -> DSchemaText $ fromSing cs+    SSchemaNumber cs -> DSchemaNumber $ fromSing cs+    SSchemaBoolean -> DSchemaBoolean+    SSchemaArray cs s -> DSchemaArray (fromSing cs) (fromSing s)+    SSchemaOptional s -> DSchemaOptional $ fromSing s+    SSchemaNull -> DSchemaNull+    SSchemaObject cs -> let+      dem :: Sing (s :: [(Symbol, Schema)]) -> [(Text, DemotedSchema)]+      dem SNil              = []+      dem (SCons (STuple2 ss ssch) fs) = withKnownSymbol ss+        $ (T.pack (symbolVal ss), fromSing ssch) : dem fs+      in DSchemaObject $ dem cs+  toSing = \case+    DSchemaText cs -> case toSing cs of+      SomeSing scs -> SomeSing $ SSchemaText scs+    DSchemaNumber cs -> case toSing cs of+      SomeSing scs -> SomeSing $ SSchemaNumber scs+    DSchemaBoolean -> SomeSing $ SSchemaBoolean+    DSchemaArray cs sch -> case (toSing cs, toSing sch) of+      (SomeSing scs, SomeSing ssch) -> SomeSing $ SSchemaArray scs ssch+    DSchemaOptional sch -> case toSing sch of+      SomeSing ssch -> SomeSing $ SSchemaOptional ssch+    DSchemaNull -> SomeSing SSchemaNull+    DSchemaObject cs -> case toSing ((\(sym,sch) -> (T.unpack sym, sch)) <$> cs) of+      SomeSing scs -> SomeSing $ SSchemaObject scs+ data FieldRepr :: (Symbol, Schema) -> Type where   FieldRepr     :: (SingI schema, KnownSymbol name)@@ -185,6 +317,7 @@ data JsonRepr :: Schema -> Type where   ReprText :: Text -> JsonRepr ('SchemaText cs)   ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)+  ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean   ReprNull :: JsonRepr 'SchemaNull   ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)   ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)@@ -259,6 +392,7 @@   parseJSON value = case sing :: Sing schema of     SSchemaText _          -> withText "String" (pure . ReprText) value     SSchemaNumber _        -> withScientific "Number" (pure . ReprNumber) value+    SSchemaBoolean         -> ReprBoolean <$> parseJSON value     SSchemaNull            -> case value of       J.Null -> pure ReprNull       _      -> typeMismatch "Null" value@@ -278,6 +412,9 @@             SSchemaNumber so -> case H.lookup fieldName h of               Just v  -> withSingI so $ FieldRepr <$> parseJSON v               Nothing -> fail "schemanumber"+            SSchemaBoolean -> case H.lookup fieldName h of+              Just v  -> FieldRepr <$> parseJSON v+              Nothing -> fail "schemaboolean"             SSchemaNull -> case H.lookup fieldName h of               Just v  -> FieldRepr <$> parseJSON v               Nothing -> fail "schemanull"@@ -295,6 +432,7 @@  instance J.ToJSON (JsonRepr a) where   toJSON ReprNull         = J.Null+  toJSON (ReprBoolean b)  = J.Bool b   toJSON (ReprText t)     = J.String t   toJSON (ReprNumber n)   = J.Number n   toJSON (ReprOptional s) = case s of

@@ -12,6 +12,7 @@ import Data.Singletons.Prelude import Data.Singletons.TypeLits import Data.Text as T+import Data.Traversable import Data.Vector as V import Data.Vinyl import Prelude as P@@ -26,7 +27,7 @@   = Valid a   | DecodingError Text       -- static   | ValidationError ErrorMap -- runtime-  deriving (Show, Eq, Functor)+  deriving (Show, Eq, Functor, Foldable, Traversable)  isValid :: ParseResult a -> Bool isValid (Valid _) = True@@ -178,6 +179,7 @@           process cs       process scs   ReprNull -> pure ()+  ReprBoolean _ -> pure ()   ReprArray v -> case sschema of     SSchemaArray acs s -> do       let

@@ -0,0 +1,43 @@+module JsonSchemaSpec (spec, main) where++import Data.Aeson as J+import Data.Proxy+import Data.Schematic+import Data.Vinyl+import JSONSchema.Draft4 as D4+import Test.Hspec+++type ArraySchema = 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])++type ArrayField = '("foo", ArraySchema)++type FieldsSchema =+  '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]++type SchemaExample = 'SchemaObject FieldsSchema++arrayData :: JsonRepr ArraySchema+arrayData = ReprArray [ReprNumber 13]++arrayField :: FieldRepr ArrayField+arrayField = FieldRepr arrayData++objectData :: Rec FieldRepr FieldsSchema+objectData = FieldRepr arrayData+  :& FieldRepr (ReprOptional (Just (ReprText "foo")))+  :& RNil++exampleData :: JsonRepr SchemaExample+exampleData = ReprObject objectData++spec :: Spec+spec = do+  it "validates simple schema" $ do+    let schema = D4.SchemaWithURI (toJsonSchema (Proxy @SchemaExample)) Nothing+    fetchHTTPAndValidate schema (toJSON exampleData) >>= \case+      Left _ -> fail "failed to validate test example"+      Right _ -> pure ()++main :: IO ()+main = hspec spec

@@ -8,12 +8,12 @@ import Test.Hspec  -type ArraySchema = 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10])+type ArraySchema = 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])  type ArrayField = '("foo", ArraySchema)  type FieldsSchema =-  '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]+  '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]  type SchemaExample = 'SchemaObject FieldsSchema @@ -31,22 +31,289 @@ exampleData :: JsonRepr SchemaExample exampleData = ReprObject objectData +type BigRecord = Rec FieldRepr+  '[ '("f1", 'SchemaNumber '[])+  ,  '("f2", 'SchemaNumber '[])+  ,  '("f3", 'SchemaNumber '[])+  ,  '("f4", 'SchemaNumber '[])+  ,  '("f5", 'SchemaNumber '[])+  ,  '("f6", 'SchemaNumber '[])+  ,  '("f7", 'SchemaNumber '[])+  ,  '("f8", 'SchemaNumber '[])+  ,  '("f9", 'SchemaNumber '[])+  ,  '("f10", 'SchemaNumber '[])+  ,  '("f11", 'SchemaNumber '[])+  ,  '("f12", 'SchemaNumber '[])+  ,  '("f13", 'SchemaNumber '[])+  ,  '("f14", 'SchemaNumber '[])+  ,  '("f15", 'SchemaNumber '[])+  ,  '("f16", 'SchemaNumber '[])+  ,  '("f17", 'SchemaNumber '[])+  ,  '("f18", 'SchemaNumber '[])+  ,  '("f19", 'SchemaNumber '[])+  ,  '("f20", 'SchemaNumber '[])+  ,  '("f21", 'SchemaNumber '[])+  ,  '("f22", 'SchemaNumber '[])+  ,  '("f23", 'SchemaNumber '[])+  ,  '("f24", 'SchemaNumber '[])+  ,  '("f25", 'SchemaNumber '[])+  ,  '("f26", 'SchemaNumber '[])+  ,  '("f27", 'SchemaNumber '[])+  ,  '("f28", 'SchemaNumber '[])+  ,  '("f29", 'SchemaNumber '[])+  ,  '("f30", 'SchemaNumber '[])+  ,  '("f31", 'SchemaNumber '[])+  ,  '("f32", 'SchemaNumber '[])+  ,  '("f33", 'SchemaNumber '[])+  ,  '("f34", 'SchemaNumber '[])+  ,  '("f35", 'SchemaNumber '[])+  ,  '("f36", 'SchemaNumber '[])+  ,  '("f37", 'SchemaNumber '[])+  ,  '("f38", 'SchemaNumber '[])+  ,  '("f39", 'SchemaNumber '[])+  ,  '("f40", 'SchemaNumber '[])+  ,  '("f41", 'SchemaNumber '[])+  ,  '("f42", 'SchemaNumber '[])+  ,  '("f43", 'SchemaNumber '[])+  ,  '("f44", 'SchemaNumber '[])+  ,  '("f45", 'SchemaNumber '[])+  ,  '("f46", 'SchemaNumber '[])+  ,  '("f47", 'SchemaNumber '[])+  ,  '("f48", 'SchemaNumber '[])+  ,  '("f49", 'SchemaNumber '[])+  ,  '("f50", 'SchemaNumber '[])+  ,  '("f51", 'SchemaNumber '[])+  ,  '("f52", 'SchemaNumber '[])+  ,  '("f53", 'SchemaNumber '[])+  ,  '("f54", 'SchemaNumber '[])+  ,  '("f55", 'SchemaNumber '[])+  ,  '("f56", 'SchemaNumber '[])+  ,  '("f57", 'SchemaNumber '[])+  ,  '("f58", 'SchemaNumber '[])+  ,  '("f59", 'SchemaNumber '[])+  ,  '("f60", 'SchemaNumber '[])+  ,  '("f61", 'SchemaNumber '[])+  ,  '("f62", 'SchemaNumber '[])+  ,  '("f63", 'SchemaNumber '[])+  ,  '("f64", 'SchemaNumber '[])+  ,  '("f65", 'SchemaNumber '[])+  ,  '("f66", 'SchemaNumber '[])+  ,  '("f67", 'SchemaNumber '[])+  ,  '("f68", 'SchemaNumber '[])+  ,  '("f69", 'SchemaNumber '[])+  ,  '("f70", 'SchemaNumber '[])+  ,  '("f71", 'SchemaNumber '[])+  ,  '("f72", 'SchemaNumber '[])+  ,  '("f73", 'SchemaNumber '[])+  ,  '("f74", 'SchemaNumber '[])+  ,  '("f75", 'SchemaNumber '[])+  ,  '("f76", 'SchemaNumber '[])+  ,  '("f77", 'SchemaNumber '[])+  ,  '("f78", 'SchemaNumber '[])+  ,  '("f79", 'SchemaNumber '[])+  ,  '("f80", 'SchemaNumber '[])+  ,  '("f81", 'SchemaNumber '[])+  ,  '("f82", 'SchemaNumber '[])+  ,  '("f83", 'SchemaNumber '[])+  ,  '("f84", 'SchemaNumber '[])+  ,  '("f85", 'SchemaNumber '[])+  ,  '("f86", 'SchemaNumber '[])+  ,  '("f87", 'SchemaNumber '[])+  ,  '("f88", 'SchemaNumber '[])+  ,  '("f89", 'SchemaNumber '[])+  ,  '("f90", 'SchemaNumber '[])+  ,  '("f91", 'SchemaNumber '[])+  ,  '("f92", 'SchemaNumber '[])+  ,  '("f93", 'SchemaNumber '[])+  ,  '("f94", 'SchemaNumber '[])+  ,  '("f95", 'SchemaNumber '[])+  ,  '("f96", 'SchemaNumber '[])+  ,  '("f97", 'SchemaNumber '[])+  ,  '("f98", 'SchemaNumber '[])+  ,  '("f99", 'SchemaNumber '[])+  ,  '("f100", 'SchemaNumber '[])+  ,  '("f101", 'SchemaNumber '[])+  ,  '("f102", 'SchemaNumber '[])+  ,  '("f103", 'SchemaNumber '[])+  ,  '("f104", 'SchemaNumber '[])+  ,  '("f105", 'SchemaNumber '[])+  ,  '("f106", 'SchemaNumber '[])+  ,  '("f107", 'SchemaNumber '[])+  ,  '("f108", 'SchemaNumber '[])+  ,  '("f109", 'SchemaNumber '[])+  ,  '("f110", 'SchemaNumber '[])+  ,  '("f111", 'SchemaNumber '[])+  ,  '("f112", 'SchemaNumber '[])+  ,  '("f113", 'SchemaNumber '[])+  ,  '("f114", 'SchemaNumber '[])+  ,  '("f115", 'SchemaNumber '[])+  ,  '("f116", 'SchemaNumber '[])+  ,  '("f117", 'SchemaNumber '[])+  ,  '("f118", 'SchemaNumber '[])+  ,  '("f119", 'SchemaNumber '[])+  ,  '("f120", 'SchemaNumber '[])+  ,  '("f121", 'SchemaNumber '[])+  ,  '("f122", 'SchemaNumber '[])+  ,  '("f123", 'SchemaNumber '[])+  ,  '("f124", 'SchemaNumber '[])+  ,  '("f125", 'SchemaNumber '[])+  ,  '("f126", 'SchemaNumber '[])+  ,  '("f127", 'SchemaNumber '[])+  ,  '("f128", 'SchemaNumber '[])+  ,  '("f129", 'SchemaNumber '[])+  ,  '("f130", 'SchemaNumber '[])+   ]++_bigRecord :: BigRecord+_bigRecord =+     FieldRepr (ReprNumber 1)+  :& FieldRepr (ReprNumber 2)+  :& FieldRepr (ReprNumber 3)+  :& FieldRepr (ReprNumber 4)+  :& FieldRepr (ReprNumber 5)+  :& FieldRepr (ReprNumber 6)+  :& FieldRepr (ReprNumber 7)+  :& FieldRepr (ReprNumber 8)+  :& FieldRepr (ReprNumber 9)+  :& FieldRepr (ReprNumber 10)+  :& FieldRepr (ReprNumber 11)+  :& FieldRepr (ReprNumber 12)+  :& FieldRepr (ReprNumber 13)+  :& FieldRepr (ReprNumber 14)+  :& FieldRepr (ReprNumber 15)+  :& FieldRepr (ReprNumber 16)+  :& FieldRepr (ReprNumber 17)+  :& FieldRepr (ReprNumber 18)+  :& FieldRepr (ReprNumber 19)+  :& FieldRepr (ReprNumber 20)+  :& FieldRepr (ReprNumber 21)+  :& FieldRepr (ReprNumber 22)+  :& FieldRepr (ReprNumber 23)+  :& FieldRepr (ReprNumber 24)+  :& FieldRepr (ReprNumber 25)+  :& FieldRepr (ReprNumber 26)+  :& FieldRepr (ReprNumber 27)+  :& FieldRepr (ReprNumber 28)+  :& FieldRepr (ReprNumber 29)+  :& FieldRepr (ReprNumber 30)+  :& FieldRepr (ReprNumber 31)+  :& FieldRepr (ReprNumber 32)+  :& FieldRepr (ReprNumber 33)+  :& FieldRepr (ReprNumber 34)+  :& FieldRepr (ReprNumber 35)+  :& FieldRepr (ReprNumber 36)+  :& FieldRepr (ReprNumber 37)+  :& FieldRepr (ReprNumber 38)+  :& FieldRepr (ReprNumber 39)+  :& FieldRepr (ReprNumber 40)+  :& FieldRepr (ReprNumber 41)+  :& FieldRepr (ReprNumber 42)+  :& FieldRepr (ReprNumber 43)+  :& FieldRepr (ReprNumber 44)+  :& FieldRepr (ReprNumber 45)+  :& FieldRepr (ReprNumber 46)+  :& FieldRepr (ReprNumber 47)+  :& FieldRepr (ReprNumber 48)+  :& FieldRepr (ReprNumber 49)+  :& FieldRepr (ReprNumber 50)+  :& FieldRepr (ReprNumber 51)+  :& FieldRepr (ReprNumber 52)+  :& FieldRepr (ReprNumber 53)+  :& FieldRepr (ReprNumber 54)+  :& FieldRepr (ReprNumber 55)+  :& FieldRepr (ReprNumber 56)+  :& FieldRepr (ReprNumber 57)+  :& FieldRepr (ReprNumber 58)+  :& FieldRepr (ReprNumber 59)+  :& FieldRepr (ReprNumber 60)+  :& FieldRepr (ReprNumber 61)+  :& FieldRepr (ReprNumber 62)+  :& FieldRepr (ReprNumber 63)+  :& FieldRepr (ReprNumber 64)+  :& FieldRepr (ReprNumber 65)+  :& FieldRepr (ReprNumber 66)+  :& FieldRepr (ReprNumber 67)+  :& FieldRepr (ReprNumber 68)+  :& FieldRepr (ReprNumber 69)+  :& FieldRepr (ReprNumber 70)+  :& FieldRepr (ReprNumber 71)+  :& FieldRepr (ReprNumber 72)+  :& FieldRepr (ReprNumber 73)+  :& FieldRepr (ReprNumber 74)+  :& FieldRepr (ReprNumber 75)+  :& FieldRepr (ReprNumber 76)+  :& FieldRepr (ReprNumber 77)+  :& FieldRepr (ReprNumber 78)+  :& FieldRepr (ReprNumber 79)+  :& FieldRepr (ReprNumber 80)+  :& FieldRepr (ReprNumber 81)+  :& FieldRepr (ReprNumber 82)+  :& FieldRepr (ReprNumber 83)+  :& FieldRepr (ReprNumber 84)+  :& FieldRepr (ReprNumber 85)+  :& FieldRepr (ReprNumber 86)+  :& FieldRepr (ReprNumber 87)+  :& FieldRepr (ReprNumber 88)+  :& FieldRepr (ReprNumber 89)+  :& FieldRepr (ReprNumber 90)+  :& FieldRepr (ReprNumber 91)+  :& FieldRepr (ReprNumber 92)+  :& FieldRepr (ReprNumber 93)+  :& FieldRepr (ReprNumber 94)+  :& FieldRepr (ReprNumber 95)+  :& FieldRepr (ReprNumber 96)+  :& FieldRepr (ReprNumber 97)+  :& FieldRepr (ReprNumber 98)+  :& FieldRepr (ReprNumber 99)+  :& FieldRepr (ReprNumber 100)+  :& FieldRepr (ReprNumber 101)+  :& FieldRepr (ReprNumber 102)+  :& FieldRepr (ReprNumber 103)+  :& FieldRepr (ReprNumber 104)+  :& FieldRepr (ReprNumber 105)+  :& FieldRepr (ReprNumber 106)+  :& FieldRepr (ReprNumber 107)+  :& FieldRepr (ReprNumber 108)+  :& FieldRepr (ReprNumber 109)+  :& FieldRepr (ReprNumber 110)+  :& FieldRepr (ReprNumber 111)+  :& FieldRepr (ReprNumber 112)+  :& FieldRepr (ReprNumber 113)+  :& FieldRepr (ReprNumber 114)+  :& FieldRepr (ReprNumber 115)+  :& FieldRepr (ReprNumber 116)+  :& FieldRepr (ReprNumber 117)+  :& FieldRepr (ReprNumber 118)+  :& FieldRepr (ReprNumber 119)+  :& FieldRepr (ReprNumber 120)+  :& FieldRepr (ReprNumber 121)+  :& FieldRepr (ReprNumber 122)+  :& FieldRepr (ReprNumber 123)+  :& FieldRepr (ReprNumber 124)+  :& FieldRepr (ReprNumber 125)+  :& FieldRepr (ReprNumber 126)+  :& FieldRepr (ReprNumber 127)+  :& FieldRepr (ReprNumber 128)+  :& FieldRepr (ReprNumber 129)+  :& FieldRepr (ReprNumber 130)+  :& RNil+ spec :: Spec spec = do   let     newFooVal = FieldRepr $ ReprArray [ReprNumber 15]     fooProxy  = Proxy @"foo"   it "gets the field from an object" $ do-    fget fooProxy objectData == arrayField+    fget fooProxy objectData `shouldBe` arrayField   it "sets the object field" $ do-    fget fooProxy (fput newFooVal objectData) == newFooVal+    fget fooProxy (fput newFooVal objectData) `shouldBe` newFooVal    describe "(using lens library) " $ do     it "get the field from an object" $ do-      objectData ^. flens (Proxy @"foo") == arrayField+      objectData ^. flens (Proxy @"foo") `shouldBe` arrayField     it "sets the object field" $ do       set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo")-        == newFooVal+        `shouldBe` newFooVal  main :: IO () main = hspec spec

@@ -2,24 +2,18 @@  module SchemaSpec (spec, main) where -import Control.Monad import Data.ByteString.Lazy import Data.Aeson import Data.Proxy import Data.Schematic-import Data.Singletons-import Data.Singletons.Prelude import Data.Vinyl import Test.Hspec-import Test.Hspec.SmallCheck-import Test.SmallCheck-import Test.SmallCheck.Series.Instances   type SchemaExample   = 'SchemaObject-    '[ '("foo", 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10]))-     , '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]+    '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))+     , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]  type TestMigration =   'Migration "test_revision"@@ -28,15 +22,6 @@  type VS = 'Versioned SchemaExample '[ TestMigration ] -exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3]))-exampleTest = ReprOptional (Just (ReprText "lil"))--exampleNumber :: JsonRepr (SchemaNumber '[NGt 10])-exampleNumber = ReprNumber 12--exampleArray :: JsonRepr (SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))-exampleArray = ReprArray [exampleNumber]- jsonExample :: JsonRepr SchemaExample jsonExample = ReprObject $   FieldRepr (ReprArray [ReprNumber 12])@@ -49,9 +34,6 @@ schemaJson2 :: ByteString schemaJson2 = "{\"foo\": [3], \"bar\": null}" -schemaJsonTopVersion :: ByteString-schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"- topObject   :: JsonRepr     ('SchemaObject@@ -88,7 +70,7 @@   it "validates versioned json" $ do     decodeAndValidateVersionedJson (Proxy @VS) schemaJson       `shouldSatisfy` isValid-  it "validates with Migration List" $ do+  it "validates versioned json with a migration list" $ do     decodeAndValidateVersionedWithMList       (Proxy @VS)       ((:&&) (Proxy @(SchemaByRevision "test_revision" VS)) (const topObject) MNil)