schematic 0.1.1.0 → 0.1.2.0
raw patch · 6 files changed
+156/−45 lines, 6 filesdep +tagged
Dependencies added: tagged
Files
- schematic.cabal +4/−1
- src/Data/Schematic.hs +92/−4
- src/Data/Schematic/Schema.hs +37/−37
- src/Data/Schematic/Utils.hs +6/−0
- src/Data/Schematic/Validation.hs +2/−2
- test/SchemaSpec.hs +15/−1
schematic.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: schematic-version: 0.1.1.0+version: 0.1.2.0 synopsis: JSON-biased spec and validation tool -- description: license: BSD3@@ -17,6 +17,7 @@ library exposed-modules: Data.Schematic+ -- , Data.Schematic.Class , Data.Schematic.Instances , Data.Schematic.Path , Data.Schematic.Schema@@ -63,6 +64,7 @@ , singletons , smallcheck , smallcheck-series+ , tagged , text , unordered-containers , validationt >= 0.1.0.1@@ -115,6 +117,7 @@ , smallcheck , smallcheck-series , singletons+ , tagged , text , unordered-containers , validationt >= 0.1.0.1
src/Data/Schematic.hs view
@@ -1,12 +1,20 @@+{-# OPTIONS -fprint-explicit-kinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+ module Data.Schematic ( module Data.Schematic.Schema+ , module Data.Schematic.Migration , module Data.Schematic.Utils , decodeAndValidateJson , parseAndValidateJson+ , parseAndValidateVersionedJson+ , parseAndValidateTopVersionJson+ , decodeAndValidateVersionedJson , isValid , isDecodingError , isValidationError , ParseResult(..)+ , Migratable ) where import Control.Monad.Validation@@ -14,15 +22,17 @@ import Data.Aeson.Types as J import Data.ByteString.Lazy as BL import Data.Functor.Identity+import Data.Schematic.Migration import Data.Schematic.Schema import Data.Schematic.Utils import Data.Schematic.Validation+import Data.Singletons.Prelude import Data.Text as T parseAndValidateJson :: forall schema- . (J.FromJSON (JsonRepr schema), TopLevel schema, Known (Sing schema))+ . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema) => J.Value -> ParseResult (JsonRepr schema) parseAndValidateJson v =@@ -30,17 +40,95 @@ Left s -> DecodingError $ T.pack s Right jsonRepr -> let- validate = validateJsonRepr (known :: Sing schema) [] jsonRepr+ validate = validateJsonRepr (sing :: Sing schema) [] jsonRepr res = runIdentity . runValidationTEither $ validate in case res of Left em -> ValidationError em Right () -> Valid jsonRepr +parseAndValidateTopVersionJson+ :: forall proxy (v :: Versioned)+ . (SingI (TopVersion (AllVersions v)))+ => proxy v+ -> J.Value+ -> ParseResult (JsonRepr (TopVersion (AllVersions v)))+parseAndValidateTopVersionJson _ v =+ case parseEither parseJSON v of+ Left s -> DecodingError $ T.pack s+ Right jsonRepr ->+ let+ validate =+ validateJsonRepr (sing :: Sing (TopVersion (AllVersions v))) [] jsonRepr+ res = runIdentity . runValidationTEither $ validate+ in case res of+ 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+ Right x -> Valid x+-- type family Migratable (revisions :: [(Revision, Schema)]) = (cs :: Constraint) where+-- Migratable '[rev] = (TopLevel (Snd rev), SingI (Snd rev))+-- Migratable revisions =+-- ( Migratable (Tail revisions)+-- , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))+-- , SingI (Snd (Head revisions)))++-- mparseBySing+-- :: Sing schema+-- -> J.Value+-- -> ParseResult (JsonRepr (Snd (Head revisions)))+-- mparseBySing s v = undefined++-- mparse+-- :: Migratable revisions+-- => Sing revisions+-- -> J.Value+-- -> ParseResult (JsonRepr (Snd (Head revisions)))+-- mparse s v =+-- let+-- st = sTail s+-- sth = sSnd $ sHead st+-- SCons x SNil -> parseAndValidateJson v+-- SCons sch _ -> case parseEither parseJSON v of+-- Left _ -> migrate <$> mparse (sTail s) v+-- 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+ decodeAndValidateJson :: forall schema- . (J.FromJSON (JsonRepr schema), TopLevel schema, Known (Sing schema))+ . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema) => BL.ByteString -> ParseResult (JsonRepr schema) decodeAndValidateJson bs = case decode bs of- Nothing -> DecodingError "invalid json"+ 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
src/Data/Schematic/Schema.hs view
@@ -13,7 +13,7 @@ import Data.Kind import Data.Maybe import Data.Schematic.Instances ()-import Data.Schematic.Utils+ import Data.Scientific import Data.Singletons.Prelude.List hiding (All) import Data.Singletons.TH@@ -49,14 +49,14 @@ STEq :: (KnownNat n) => Sing n -> Sing ('TEq n) STLe :: (KnownNat n) => Sing n -> Sing ('TLe n) STGt :: (KnownNat n) => Sing n -> Sing ('TGt n)- STRegex :: (KnownSymbol s, Known (Sing s)) => Sing s -> Sing ('TRegex s)- STEnum :: (All KnownSymbol ss, Known (Sing ss)) => Sing ss -> Sing ('TEnum ss)+ STRegex :: (KnownSymbol s, SingI s) => Sing s -> Sing ('TRegex s)+ STEnum :: (All KnownSymbol ss, SingI ss) => Sing ss -> Sing ('TEnum ss) -instance (KnownNat n) => Known (Sing ('TEq n)) where known = STEq known-instance (KnownNat n) => Known (Sing ('TGt n)) where known = STGt known-instance (KnownNat n) => Known (Sing ('TLe n)) where known = STLe known-instance (KnownSymbol s, Known (Sing s)) => Known (Sing ('TRegex s)) where known = STRegex known-instance (All KnownSymbol ss, Known (Sing ss)) => Known (Sing ('TEnum ss)) where known = STEnum known+instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing+instance (KnownNat n) => SingI ('TGt n) where sing = STGt 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 Eq (Sing ('TEq n)) where _ == _ = True instance Eq (Sing ('TLe n)) where _ == _ = True@@ -75,9 +75,9 @@ SNGt :: KnownNat n => Sing n -> Sing ('NGt n) SNLe :: KnownNat n => Sing n -> Sing ('NLe n) -instance KnownNat n => Known (Sing ('NEq n)) where known = SNEq known-instance KnownNat n => Known (Sing ('NGt n)) where known = SNGt known-instance KnownNat n => Known (Sing ('NLe n)) where known = SNLe known+instance KnownNat n => SingI ('NEq n) where sing = SNEq sing+instance KnownNat n => SingI ('NGt n) where sing = SNGt sing+instance KnownNat n => SingI ('NLe n) where sing = SNLe sing instance Eq (Sing ('NEq n)) where _ == _ = True instance Eq (Sing ('NLe n)) where _ == _ = True@@ -90,7 +90,7 @@ data instance Sing (ac :: ArrayConstraint) where SAEq :: KnownNat n => Sing n -> Sing ('AEq n) -instance KnownNat n => Known (Sing ('AEq n)) where known = SAEq known+instance KnownNat n => SingI ('AEq n) where sing = SAEq sing instance Eq (Sing ('AEq n)) where _ == _ = True @@ -104,25 +104,25 @@ deriving (Generic) data instance Sing (schema :: Schema) where- SSchemaText :: Known (Sing tcs) => Sing tcs -> Sing ('SchemaText tcs)- SSchemaNumber :: Known (Sing ncs) => Sing ncs -> Sing ('SchemaNumber ncs)- SSchemaArray :: (Known (Sing acs), Known (Sing schema)) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)- SSchemaObject :: Known (Sing fields) => Sing fields -> Sing ('SchemaObject fields)- SSchemaOptional :: Known (Sing s) => Sing s -> Sing ('SchemaOptional s)+ SSchemaText :: SingI tcs => Sing tcs -> Sing ('SchemaText tcs)+ SSchemaNumber :: SingI ncs => Sing ncs -> Sing ('SchemaNumber ncs)+ SSchemaArray :: (SingI acs, SingI schema) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)+ SSchemaObject :: SingI fields => Sing fields -> Sing ('SchemaObject fields)+ SSchemaOptional :: SingI s => Sing s -> Sing ('SchemaOptional s) SSchemaNull :: Sing 'SchemaNull -instance Known (Sing sl) => Known (Sing ('SchemaText sl)) where- known = SSchemaText known-instance Known (Sing sl) => Known (Sing ('SchemaNumber sl)) where- known = SSchemaNumber known-instance Known (Sing 'SchemaNull) where- known = SSchemaNull-instance (Known (Sing ac), Known (Sing s)) => Known (Sing ('SchemaArray ac s)) where- known = SSchemaArray known known-instance Known (Sing stl) => Known (Sing ('SchemaObject stl)) where- known = SSchemaObject known-instance Known (Sing s) => Known (Sing ('SchemaOptional s)) where- known = SSchemaOptional known+instance SingI sl => SingI ('SchemaText sl) where+ sing = SSchemaText sing+instance SingI sl => SingI ('SchemaNumber sl) where+ sing = SSchemaNumber sing+instance SingI 'SchemaNull where+ sing = SSchemaNull+instance (SingI ac, SingI s) => SingI ('SchemaArray ac s) where+ sing = SSchemaArray sing sing+instance SingI stl => SingI ('SchemaObject stl) where+ sing = SSchemaObject sing+instance SingI s => SingI ('SchemaOptional s) where+ sing = SSchemaOptional sing instance Eq (Sing ('SchemaText cs)) where _ == _ = True instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True@@ -133,7 +133,7 @@ data FieldRepr :: (Symbol, Schema) -> Type where FieldRepr- :: (Known (Sing schema), KnownSymbol name)+ :: (SingI schema, KnownSymbol name) => JsonRepr schema -> FieldRepr '(name, schema) @@ -146,10 +146,10 @@ knownFieldSchema :: forall proxy fieldName schema- . Known (Sing schema)+ . SingI schema => proxy '(fieldName, schema) -> Sing schema-knownFieldSchema _ = known+knownFieldSchema _ = sing deriving instance Show (JsonRepr schema) => Show (FieldRepr '(name, schema)) @@ -158,7 +158,7 @@ instance ( KnownSymbol name- , Known (Sing schema)+ , SingI schema , Serial m (JsonRepr schema) ) => Serial m (FieldRepr '(name, schema)) where series = FieldRepr <$> series@@ -230,14 +230,14 @@ ReprOptional a == ReprOptional b = a == b fromOptional- :: (Known (Sing s))+ :: SingI s => Sing ('SchemaOptional s) -> J.Value -> Parser (Maybe (JsonRepr s)) fromOptional _ = parseJSON -instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where- parseJSON value = case known :: Sing schema of+instance SingI schema => J.FromJSON (JsonRepr schema) where+ parseJSON value = case sing :: Sing schema of SSchemaText _ -> withText "String" (pure . ReprText) value SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value SSchemaNull -> case value of@@ -297,4 +297,4 @@ type family TopLevel (schema :: Schema) :: Constraint where TopLevel ('SchemaArray acs s) = () TopLevel ('SchemaObject o) = ()- TopLevel spec = FalseConstraint spec+ TopLevel spec = 'True ~ 'False
src/Data/Schematic/Utils.hs view
@@ -34,3 +34,9 @@ instance (Known (Sing a), Known (Rec Sing tl)) => Known (Rec Sing (a ': tl)) where known = known :& known++data Dict c where+ Dict :: c => Dict c++instance c => Known (Dict c) where+ known = Dict
src/Data/Schematic/Validation.hs view
@@ -24,8 +24,8 @@ data ParseResult a = Valid a- | DecodingError Text- | ValidationError ErrorMap+ | DecodingError Text -- static+ | ValidationError ErrorMap -- runtime deriving (Show, Eq, Functor) isValid :: ParseResult a -> Bool
test/SchemaSpec.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fprint-potential-instances #-}+ module SchemaSpec (spec, main) where import Control.Monad@@ -16,8 +18,14 @@ type SchemaExample = SchemaObject '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))- , '("bar", SchemaOptional (SchemaText '[TRegex "\\w+", TEnum '["foo", "bar"]]))]+ , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))] +type VS =+ 'Versioned SchemaExample+ '[ 'Migration "test_revision"+ '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))+ , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ] ]+ exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3])) exampleTest = ReprOptional (Just (ReprText "lil")) @@ -39,6 +47,9 @@ schemaJson2 :: ByteString schemaJson2 = "{\"foo\": [3], \"bar\": null}" +schemaJsonTopVersion :: ByteString+schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"+ spec :: Spec spec = do -- it "show/read JsonRepr properly" $@@ -54,6 +65,9 @@ it "validates incorrect representation" $ ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample)) `shouldSatisfy` isValidationError+ it "validates versioned json" $ do+ (decodeAndValidateVersionedJson (Proxy @VS) schemaJsonTopVersion)+ `shouldSatisfy` isValid main :: IO () main = hspec spec