git.iko.soy/schematic
on master help sign in
WIP tests
f37247dDenis Redozubov
schematic.cabal+5−3
compare with master
unifiedsplit
@@ -19,7 +19,6 @@ library
19 exposed-modules: Data.Aeson.Validation
19 exposed-modules: Data.Aeson.Validation
20 , Data.Schematic
20 , Data.Schematic
21 , Data.Schematic.Schema
21 , Data.Schematic.Schema
22− , Data.Schematic.Validation
23 -- ghc-options:
22 -- ghc-options:
24 -- other-modules:
23 -- other-modules:
25 default-extensions: ConstraintKinds
24 default-extensions: ConstraintKinds
@@ -27,6 +26,7 @@ library
27 , DefaultSignatures
26 , DefaultSignatures
28 , DeriveFunctor
27 , DeriveFunctor
29 , DeriveFoldable
28 , DeriveFoldable
29+ , DeriveGeneric
30 , DeriveDataTypeable
30 , DeriveDataTypeable
31 , FlexibleContexts
31 , FlexibleContexts
32 , FlexibleInstances
32 , FlexibleInstances
@@ -55,10 +55,10 @@ library
55 build-depends: base >=4.9 && <4.10
55 build-depends: base >=4.9 && <4.10
56 , aeson >= 1
56 , aeson >= 1
57 , deriving-compat
57 , deriving-compat
58− , recursion-schemes
59 , regex-compat
58 , regex-compat
60 , scientific
59 , scientific
61 , singletons
60 , singletons
61+ , smallcheck
62 , text
62 , text
63 , unordered-containers
63 , unordered-containers
64 , validationt >= 0.1.0.1
64 , validationt >= 0.1.0.1
@@ -76,6 +76,7 @@ test-suite spec
76 , DataKinds
76 , DataKinds
77 , DeriveFunctor
77 , DeriveFunctor
78 , DeriveFoldable
78 , DeriveFoldable
79+ , DeriveGeneric
79 , DeriveDataTypeable
80 , DeriveDataTypeable
80 , FlexibleContexts
81 , FlexibleContexts
81 , FlexibleInstances
82 , FlexibleInstances
@@ -103,9 +104,10 @@ test-suite spec
103 , hspec >= 2.2.0
104 , hspec >= 2.2.0
104 , hspec-core
105 , hspec-core
105 , hspec-discover
106 , hspec-discover
106− , recursion-schemes
107+ , hspec-smallcheck
107 , regex-compat
108 , regex-compat
108 , schematic
109 , schematic
110+ , singletons
109 , text
111 , text
110 , unordered-containers
112 , unordered-containers
111 , validationt >= 0.1.0.1
113 , validationt >= 0.1.0.1
src/Data/Aeson/Validation.hs+1−3
@@ -5,17 +5,15 @@ import Control.Applicative
5import Control.Monad
5import Control.Monad
6import Data.Aeson.Types as J
6import Data.Aeson.Types as J
7import Data.Foldable as F
7import Data.Foldable as F
8−import Data.Functor.Foldable
9import Data.HashMap.Strict as H
8import Data.HashMap.Strict as H
10import Data.Maybe
9import Data.Maybe
11import Data.Proxy
10import Data.Proxy
12−import Data.Schematic.Validation
11+import Data.Schematic.Schema
13import Data.Singletons
12import Data.Singletons
14import Data.Singletons.Decide
13import Data.Singletons.Decide
15import Data.Text as T
14import Data.Text as T
16import Data.Traversable
15import Data.Traversable
17
16
18−
19(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool
17(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool
20(<&&>) = liftA2 (&&)
18(<&&>) = liftA2 (&&)
21
19
src/Data/Schematic.hs+5−1
@@ -1 +1,5 @@
1−module Data.Schematic where
1+module Data.Schematic
2+ ( module Data.Schematic.Schema
3+ ) where
4+
5+import Data.Schematic.Schema
src/Data/Schematic/Schema.hs+171−143
@@ -1,151 +1,179 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE OverloadedLists #-}
3−{-# LANGUAGE InstanceSigs #-}
3+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE UndecidableInstances #-}
5{-# OPTIONS_GHC -fprint-explicit-kinds #-}
4{-# OPTIONS_GHC -fprint-explicit-kinds #-}
6
5
7module Data.Schematic.Schema where
6module Data.Schematic.Schema where
8
7
9−import Data.Functor.Foldable
8+import Control.Applicative
9+import Control.Category ((<<<), (>>>))
10+import Control.Monad
11+import Data.Aeson as J
12+import Data.Aeson.Types as J
13+import Data.Eq.Deriving (deriveEq1)
14+import Data.Foldable as F
15+import Data.Functor.Classes
16+import Data.HashMap.Strict as H
10−import Data.Kind hiding (Type)
17+import Data.Kind
18+import Data.Maybe
19+import Data.Scientific
20+import Data.Singletons.Decide
21+import Data.Singletons.Prelude.List
22+import Data.Singletons.TH
23+import Data.Singletons.TypeLits
24+import Data.Text as T
25+import Data.Vector as V
26+import Data.Vinyl hiding (Dict)
11−import Data.Proxy
27+import Data.Vinyl.Functor
12−import Data.Schematic.Validation
13−import Data.Text (Text)
14−import GHC.Generics
28+import GHC.Generics (Generic)
15−import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
29+import Test.SmallCheck.Series
16−
30+import Text.Show.Deriving (deriveShow1)
17−
31+
32+
18−type family JT (s :: k) :: JType where
33+type family CRepr (s :: Schema) :: Type where
19− JT (SNumber cs) = 'JNumber
34+ CRepr (SchemaText cs) = TextConstraint
20− JT (SText cs) = 'JText
35+ CRepr (SchemaNumber cs) = NumberConstraint
21− JT (SObject els) = 'JObject
36+ CRepr (SchemaObject fs) = (String, Schema)
22− JT (SArray cs s) = 'JArray
37+ CRepr (SchemaArray ar s) = ArrayConstraint
23− JT (Field field ty cs) = JT ty
38+
24−
39+data TextConstraint
25−class Constrained (ty :: JType) c where
40+ = TEq Nat
26− cRep :: Proxy ty -> Proxy c -> CRepr ty
41+ | TLe Nat
27−
42+ | TGt Nat
28−-- Validators
43+ | Regex Symbol
29−
44+ deriving (Generic)
30−data LengthEqNat nat
45+
31−
46+data instance Sing (tc :: TextConstraint) where
32−instance KnownNat nat => Constrained 'JText (LengthEqNat nat) where
47+ STextLengthEq :: Sing n -> Sing (TEq n)
33− cRep _ _ = LengthEq $ natVal (Proxy @nat)
48+ STextLengthLe :: Sing n -> Sing (TLe n)
34−
49+ STextLengthGt :: Sing n -> Sing (TGt n)
35−data Gt nat
50+
36−
51+instance Eq (Sing (TEq n)) where a == b = True
37−instance KnownNat nat => Constrained 'JNumber (Gt nat) where
52+instance Eq (Sing (TLe n)) where a == b = True
38− cRep _ _ = Gt $ natVal (Proxy @nat)
53+instance Eq (Sing (TGt n)) where a == b = True
39−
54+
40−instance KnownNat nat => Constrained 'JArray (LengthEqNat nat) where
55+data NumberConstraint
41− cRep _ _ = LengthArrEq $ natVal (Proxy @nat)
56+ = NLe Nat
42−
57+ | NGt Nat
43−-- /Validators
58+ | NEq Nat
44−
59+ deriving (Generic)
45−data Field field ty schema
60+
46−
61+data instance Sing (nc :: NumberConstraint) where
47−data Empty
62+ SNumberEq :: Sing n -> Sing (NEq n)
48−
63+ SNumberGt :: Sing n -> Sing (NGt n)
49−class Verifiable ty cs where
64+ SNumberLe :: Sing n -> Sing (NLe n)
50− schema :: Proxy ty -> Proxy cs -> [CRepr ty]
65+
51−
52−instance
66+instance Eq (Sing (NEq n)) where a == b = True
53− ( Constrained 'JText c
67+instance Eq (Sing (NLe n)) where a == b = True
54− , Verifiable 'JText cs )
68+instance Eq (Sing (NGt n)) where a == b = True
55− => Verifiable 'JText (c ': cs) where
69+
56− schema _ _ = cRep (Proxy @'JText) (Proxy @c)
70+data ArrayConstraint
57− : schema (Proxy @'JText) (Proxy @cs)
71+ = AEq Nat
72+ deriving (Generic)
73+
74+data instance Sing (ac :: ArrayConstraint) where
75+ SArrayEq :: Sing n -> Sing (AEq n)
76+
77+instance Eq (Sing (AEq n)) where a == b = True
78+
79+data Schema
80+ = SchemaText [TextConstraint]
81+ | SchemaNumber [NumberConstraint]
82+ | SchemaObject [(Symbol, Schema)]
83+ | SchemaArray [ArrayConstraint] Schema
84+ | SchemaNull
85+ deriving (Generic)
86+
87+data instance Sing (schema :: Schema) where
88+ SSchemaText :: Sing tcs -> Sing (SchemaText tcs)
89+ SSchemaNumber :: Sing ncs -> Sing (SchemaNumber ncs)
90+ SSchemaArray :: Sing acs -> Sing schema -> Sing (SchemaArray acs schema)
91+ SSchemaObject :: Sing fields -> Sing (SchemaObject fields)
92+ SSchemaNull :: Sing SchemaNull
93+
94+instance Eq (Sing (SchemaText cs)) where a == b = True
95+instance Eq (Sing (SchemaNumber cs)) where a == b = True
96+instance Eq (Sing SchemaNull) where a == b = True
97+instance Eq (Sing (SchemaArray as s)) where a == b = True
98+instance Eq (Sing (SchemaObject cs)) where a == b = True
99+
100+data FieldRepr :: (Symbol, Schema) -> Type where
101+ FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
102+
103+instance Eq (JsonRepr schema) => Eq (FieldRepr '(name, schema)) where
104+ FieldRepr a == FieldRepr b = a == b
58
105
59instance
106instance
60− ( Constrained 'JNumber c
61− , Verifiable 'JNumber cs )
62− => Verifiable 'JNumber (c ': cs) where
63− schema _ _ = cRep (Proxy @'JNumber) (Proxy @c)
64− : schema (Proxy @'JNumber) (Proxy @cs)
65−
66−instance Verifiable jty '[] where
67− schema _ _ = []
68−
69−instance
70− ( Constrained 'JArray c
71− , Verifiable 'JArray cs )
72− => Verifiable 'JArray (c ': cs) where
73− schema _ _ = cRep (Proxy @'JArray) (Proxy @c)
74− : schema (Proxy @'JArray) (Proxy @cs)
75−
76−instance
77− ( SchemaConstructor jty
78− , Verifiable 'JObject fs
79− , KnownSymbol field
107+ ( KnownSymbol name
80− , Verifiable jty cs )
108+ , Serial m (JsonRepr schema) )
81− => Verifiable 'JObject ((Field field jty cs) ': fs) where
109+ => Serial m (FieldRepr '(name, schema)) where
82− schema _ _ = (fieldName, fieldSchema) : schema (Proxy @'JObject) (Proxy @fs)
110+ series = FieldRepr <$> series
111+
112+data JsonRepr :: Schema -> Type where
113+ ReprText :: Text -> JsonRepr (SchemaText cs)
114+ ReprNumber :: Scientific -> JsonRepr (SchemaNumber cs)
115+ ReprNull :: JsonRepr SchemaNull
116+ ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
117+ ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
118+
119+instance Eq (Rec FieldRepr fs) => Eq (JsonRepr (SchemaObject fs)) where
120+ ReprObject a == ReprObject b = a == b
121+
122+instance Eq (JsonRepr (SchemaText cs)) where
123+ ReprText a == ReprText b = a == b
124+
125+instance Eq (JsonRepr (SchemaNumber cs)) where
126+ ReprNumber a == ReprNumber b = a == b
127+
128+instance Eq (JsonRepr SchemaNull) where
129+ ReprNull == ReprNull = True
130+
131+instance Eq (JsonRepr s) => Eq (JsonRepr (SchemaArray as s)) where
132+ ReprArray a == ReprArray b = a == b
133+
134+instance (SingI schema) => J.FromJSON (JsonRepr schema) where
135+ parseJSON value = case sing :: Sing schema of
136+ SSchemaText _ -> withText "String" (pure . ReprText) value
137+ SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
138+ SSchemaNull -> pure ReprNull
139+ SSchemaArray c s -> withArray "Array" f value
140+ where
141+ f = fmap ReprArray . (withSingI s $ traverse parseJSON)
142+ SSchemaObject fs -> ReprObject <$> withObject "Object" (demoteFields fs) value
143+
144+demoteFields
145+ :: SList s
146+ -> H.HashMap Text J.Value
147+ -> Parser (Rec FieldRepr s)
148+demoteFields SNil h
149+ | H.null h = pure RNil
150+ | otherwise = mzero
151+demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
152+ let fieldName = T.pack $ symbolVal (Proxy @fn)
153+ fieldRepr <- case H.lookup fieldName h of
154+ Just v -> FieldRepr <$> (withSingI s $ parseJSON v)
155+ Nothing -> mzero
156+ (fieldRepr :&) <$> demoteFields tl h
157+
158+instance J.ToJSON (JsonRepr a) where
159+ toJSON ReprNull = J.Null
160+ toJSON (ReprText t) = J.String t
161+ toJSON (ReprNumber n) = J.Number n
162+ toJSON (ReprArray v) = J.Array $ toJSON <$> v
163+ toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
83 where
164 where
84− fieldName = symbolVal (Proxy @field)
165+ extract :: forall name s . (KnownSymbol name)
85− fieldSchema = constructor (Proxy @jty) $ schema (Proxy @jty) (Proxy @cs)
166+ => FieldRepr '(name, s)
86−
167+ -> (Text, Value)
87−class SchemaConstructor jty where
168+ extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s)
88− constructor :: Proxy jty -> [CRepr jty] -> Schema
169+ fold :: Rec FieldRepr fs -> [(Text, J.Value)]
89−
170+ fold = \case
90−instance SchemaConstructor 'JText where
171+ RNil -> []
91− constructor _ = Fix . SchemaText
172+ fr@(FieldRepr s) :& tl -> (extract fr) : fold tl
92−
173+
93−instance SchemaConstructor 'JNumber where
174+class FalseConstraint
94− constructor _ = Fix . SchemaNumber
175+
95−
176+type family TopLevel (spec :: Schema) :: Constraint where
96−instance SchemaConstructor 'JObject where
177+ TopLevel (SchemaArray a e) = ()
97− constructor _ = Fix . SchemaObject
178+ TopLevel (SchemaObject o) = ()
98−
99−class Schematic ty where
100− build :: Proxy ty -> Schema
101−
102−data SText cs
103−
104−instance (Verifiable 'JText cs) => Schematic (SText cs) where
105− build _ = constructor (Proxy @(JT (SText cs))) $ schema (Proxy @JText) (Proxy @cs)
106−
107−data SNumber cs
108−
109−instance (Verifiable 'JNumber cs) => Schematic (SNumber cs) where
110− build _ = constructor (Proxy @(JT (SNumber cs)))
111− $ schema (Proxy @'JNumber) (Proxy @cs)
112−
113−instance
114− ( Verifiable (JT ty) cs
115− , SchemaConstructor (JT ty))
116− => Schematic (Field field ty cs) where
117− build _ = constructor (Proxy @(JT (Field field ty cs)))
118− $ schema (Proxy @(JT (Field field ty cs))) (Proxy @cs)
119−
120−data SObject els
121−
122−instance
123− ( Verifiable 'JObject els )
124− => Schematic (SObject els) where
125− build _ =
126− constructor (Proxy @'JObject) $ schema (Proxy @(JT (SObject els))) (Proxy @els)
127−
128−data SArray cs s
129−
130−instance
131− ( Schematic s
132− , Verifiable 'JArray cs )
133− => Schematic (SArray cs s) where
134− build _ =
135− Fix $ SchemaArray
136− (schema (Proxy @'JArray) (Proxy @cs))
137− (build (Proxy @s))
138−
139−-- | Shows it's top-level definition according to the json-schema
140−class Schematic spec => TopLevel spec
179+ TopLevel spec = FalseConstraint
141−
142−instance (Schematic (SObject els)) => TopLevel (SObject els)
143−
144−instance Schematic (SArray cs s) => TopLevel (SArray cs s)
145−
146−-- | TODO: abstract over objects and arrays
147−toSchema
148− :: forall spec. TopLevel spec
149− => Proxy spec
150− -> Schema
151−toSchema = build
src/Data/Schematic/Validation.hsdeleted−188
@@ -1,188 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE OverloadedLists #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# OPTIONS_GHC -fprint-explicit-kinds #-}
5−
6−module Data.Schematic.Validation where
7−
8−import Control.Applicative
9−import Control.Category ((<<<), (>>>))
10−import Control.Monad
11−import Data.Aeson as J
12−import Data.Aeson.Types as J
13−import Data.Eq.Deriving (deriveEq1)
14−import Data.Foldable as F
15−import Data.Functor.Classes
16−import Data.Functor.Foldable
17−import Data.HashMap.Strict as H
18−import Data.Kind
19−import Data.Maybe
20−import Data.Scientific
21−import Data.Singletons.Decide
22−import Data.Singletons.Prelude.List
23−import Data.Singletons.TH
24−import Data.Singletons.TypeLits
25−import Data.Text as T
26−import Data.Vector as V
27−import Data.Vinyl hiding (Dict)
28−import Data.Vinyl.Functor
29−import Text.Show.Deriving (deriveShow1)
30−
31−
32−-- -- | Type Tags
33−data JType
34− = JText
35− | JNumber
36− | JArray
37− | JObject
38− | JNull
39− deriving (Show, Eq)
40−
41−genSingletons [ ''JType ]
42−
43−-- instance Show (Sing JText) where showsPrec 4 _ = showString "SJText"
44−-- instance Show (Sing JNumber) where showsPrec 4 _ = showString "SJNumber"
45−-- instance Show (Sing JArray) where showsPrec 4 _ = showString "SJArray"
46−-- instance Show (Sing JObject) where showsPrec 4 _ = showString "SJObject"
47−-- instance Show (Sing JNull) where showsPrec 4 _ = showString "SJNull"
48−
49−-- instance Eq (Sing JText) where (==) _ _ = True
50−-- instance Eq (Sing JNumber) where (==) _ _ = True
51−-- instance Eq (Sing JArray) where (==) _ _ = True
52−-- instance Eq (Sing JObject) where (==) _ _ = True
53−-- instance Eq (Sing JNull) where (==) _ _ = True
54−
55−type family CRepr (jty :: Schema) :: Type where
56− CRepr (SchemaText cs) = TextConstraint
57− CRepr (SchemaNumber cs) = NumberConstraint
58− CRepr (SchemaObject fs) = (String, Schema)
59− CRepr (SchemaArray ar s) = ArrayConstraint
60−
61−data TextConstraint
62− = TEq Nat
63− | TLe Nat
64− | TGt Nat
65− | Regex Symbol
66−
67−data instance Sing (tc :: TextConstraint) where
68− STextLengthEq :: Sing n -> Sing (TEq n)
69− STextLengthLe :: Sing n -> Sing (TLe n)
70− STextLengthGt :: Sing n -> Sing (TGt n)
71−
72−data NumberConstraint
73− = NLe Nat
74− | NGt Nat
75− | NEq Nat
76−
77−data instance Sing (nc :: NumberConstraint) where
78− SNumberEq :: Sing n -> Sing (NEq n)
79− SNumberGt :: Sing n -> Sing (NGt n)
80− SNumberLe :: Sing n -> Sing (NLe n)
81−
82−data ArrayConstraint
83− = AEq Nat
84−
85−data instance Sing (ac :: ArrayConstraint) where
86− SArrayEq :: Sing n -> Sing (AEq n)
87−
88−data Schema
89− = SchemaText [TextConstraint]
90− | SchemaNumber [NumberConstraint]
91− | SchemaObject [(Symbol, Schema)]
92− | SchemaArray [ArrayConstraint] Schema
93− | SchemaNull
94−
95−data instance Sing (schema :: Schema) where
96− SSchemaText :: Sing tcs -> Sing (SchemaText tcs)
97− SSchemaNumber :: Sing ncs -> Sing (SchemaNumber ncs)
98− SSchemaArray :: Sing acs -> Sing schema -> Sing (SchemaArray acs schema)
99− SSchemaObject :: Sing fields -> Sing (SchemaObject fields)
100− SSchemaNull :: Sing SchemaNull
101−
102−data FieldRepr :: (Symbol, Schema) -> Type where
103− FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
104−
105−data JsonRepr :: Schema -> Type where
106− ReprText :: Text -> JsonRepr (SchemaText cs)
107− ReprNumber :: Scientific -> JsonRepr (SchemaNumber cs)
108− ReprNull :: JsonRepr SchemaNull
109− ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
110− ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
111−
112−instance (SingI schema) => J.FromJSON (JsonRepr schema) where
113− parseJSON value = case sing :: Sing schema of
114− SSchemaText _ -> withText "String" (pure . ReprText) value
115− SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
116− SSchemaNull -> pure ReprNull
117− SSchemaArray c s -> withArray "Array" f value
118− where
119− f v = do
120− values <- withSingI s $ traverse parseJSON v
121− pure $ ReprArray values
122− SSchemaObject fs -> ReprObject <$> withObject "Object" (demoteFields fs) value
123−
124−demoteFields
125− :: SList s
126− -> H.HashMap Text J.Value
127− -> Parser (Rec FieldRepr s)
128−demoteFields SNil h
129− | H.null h = pure RNil
130− | otherwise = mzero
131−demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
132− let fieldName = T.pack $ symbolVal (Proxy @fn)
133− fieldRepr <- case H.lookup fieldName h of
134− Just v -> FieldRepr <$> (withSingI s $ parseJSON v)
135− Nothing -> mzero
136− (fieldRepr :&) <$> demoteFields tl h
137−
138−instance J.ToJSON (JsonRepr a) where
139− toJSON ReprNull = J.Null
140− toJSON (ReprText t) = J.String t
141− toJSON (ReprNumber n) = J.Number n
142− toJSON (ReprArray v) = J.Array $ toJSON <$> v
143− toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
144− where
145− extract
146− :: forall name s
147− . (KnownSymbol name)
148− => FieldRepr '(name, s)
149− -> (Text, Value)
150− extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s)
151− fold :: Rec FieldRepr fs -> [(Text, J.Value)]
152− fold = \case
153− RNil -> []
154− fr@(FieldRepr s) :& tl -> (extract fr) : fold tl
155−
156−type Spec
157− = SchemaObject
158− '[ '("foo", SchemaArray '[AEq 3] (SchemaNumber '[NGt 10]))
159− , '("bar", SchemaText '[Regex "\\w+"])]
160−
161−spec :: (SingKind Schema, SingI Spec) => DemoteRep Schema
162−spec = fromSing (sing :: Sing Spec)
163−
164−exampleTest :: JsonRepr (SchemaText '[TEq 3])
165−exampleTest = ReprText "ololo"
166−
167−exampleNumber :: JsonRepr (SchemaNumber '[NEq 3])
168−exampleNumber = ReprNumber 3
169−
170−exampleArray :: JsonRepr (SchemaArray '[AEq 1] (SchemaNumber '[NEq 3]))
171−exampleArray = ReprArray [exampleNumber]
172−
173−exampleObject
174− :: JsonRepr (SchemaObject '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NEq 3]))] )
175−exampleObject = ReprObject $ FieldRepr exampleArray :& RNil
176−
177−example :: JsonRepr Spec
178−example = ReprObject $
179− FieldRepr (ReprArray [ReprNumber 3])
180− :& FieldRepr (ReprText "test")
181− :& RNil
182−
183−class FalseConstraint
184−
185−type family TopLevel (spec :: Schema) :: Constraint where
186− TopLevel (SchemaArray a e) = ()
187− TopLevel (SchemaObject o) = ()
188− TopLevel spec = FalseConstraint
stack.yaml+5−4
@@ -36,12 +36,13 @@ resolver: lts-8.12
36# non-dependency (i.e. a user package), and its test suites and benchmarks
36# non-dependency (i.e. a user package), and its test suites and benchmarks
37# will not be run. This is useful for tweaking upstream packages.
37# will not be run. This is useful for tweaking upstream packages.
38packages:
38packages:
39−- location:
39+#- location:
40− git: https://github.com/typeable/validationt.git
40+ #git: https://github.com/typeable/validationt.git
41− commit: 24578c9fd408179358c641ee1fff0eb182591f4b
41+ #commit: 24578c9fd408179358c641ee1fff0eb182591f4b
42- '.'
42- '.'
43
43
44−extra-deps: []
44+extra-deps:
45+- validationt-0.2.0.0
45
46
46# Override default flag values for local packages and extra-deps
47# Override default flag values for local packages and extra-deps
47flags: {}
48flags: {}
test/SchemaSpec.hs+30−35
@@ -1,50 +1,45 @@
1module SchemaSpec (spec, main) where
1module SchemaSpec (spec, main) where
2
2
3−import Data.Functor.Foldable
3+import Data.Aeson
4import Data.Proxy
4import Data.Proxy
5−import Data.Schematic.Schema
5+import Data.Schematic
6+import Data.Singletons
6−import Data.Schematic.Validation
7+import Data.Vinyl
7import Test.Hspec
8import Test.Hspec
9+import Test.Hspec.SmallCheck
8
10
9
11
10−type TextSchema = SText '[LengthEqNat 2]
12+type SchemaExample
13+ = SchemaObject
14+ '[ '("foo", SchemaArray '[AEq 3] (SchemaNumber '[NGt 10]))
15+ , '("bar", SchemaText '[Regex "\\w+"])]
11
16
12−type NumberSchema = SNumber '[ Gt 3]
17+schemaExample :: (SingKind Schema, SingI SchemaExample) => DemoteRep Schema
18+schemaExample = fromSing (sing :: Sing SchemaExample)
13
19
14−type ArraySchema = SArray '[ LengthEqNat 3 ] NumberSchema
20+exampleTest :: JsonRepr (SchemaText '[TEq 3])
21+exampleTest = ReprText "lilo"
15
22
16−type ObjectSchema
23+exampleNumber :: JsonRepr (SchemaNumber '[NEq 3])
17− = SObject "CarrierObj"
24+exampleNumber = ReprNumber 3
18− '[ Field "carrier" 'JText '[LengthEqNat 2]
25+
19− , Field "number_gt_3" 'JNumber '[Gt 3] ]
26+exampleArray :: JsonRepr (SchemaArray '[AEq 1] (SchemaNumber '[NEq 3]))
27+exampleArray = ReprArray [exampleNumber]
28+
29+exampleObject
30+ :: JsonRepr (SchemaObject '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NEq 3]))] )
31+exampleObject = ReprObject $ FieldRepr exampleArray :& RNil
32+
33+example :: JsonRepr SchemaExample
34+example = ReprObject $
35+ FieldRepr (ReprArray [ReprNumber 3])
36+ :& FieldRepr (ReprText "test")
37+ :& RNil
20
38
21spec :: Spec
39spec :: Spec
22spec = do
40spec = do
23− let
41+ it "decode/encode JsonRepr properly" $ do
24− textSchema = Fix $ SchemaText [LengthEq 2]
42+ property $ \(a :: JsonRepr SchemaExample) -> decode (encode a) == Just a
25− numberSchema = Fix $ SchemaNumber [Gt 3]
26− arraySchema = Fix $ SchemaArray [LengthArrEq 3]
27− $ Fix $ SchemaNumber [Gt 3]
28− objectSchema = Fix $ SchemaObject
29− [ ("carrier", textSchema)
30− , ("number_gt_3", numberSchema)]
31−
32− describe "Schema translation: " $ do
33− it "translate string schema" $ do
34− build (Proxy @TextSchema) `shouldBe` textSchema
35− it "translates number schema" $ do
36− build (Proxy @NumberSchema) `shouldBe` numberSchema
37− it "translates array schema" $ do
38− build (Proxy @ArraySchema) `shouldBe` arraySchema
39− it "translates object schema" $ do
40− build (Proxy @ObjectSchema) `shouldBe` objectSchema
41− -- it "translates Generate symbols" $ do
42− -- build (Proxy @GeneratorSchema) `shouldBe` objectSchema
43−
44− describe "Types listing: " $ do
45− it "lists types"
46− $ typesOf (build (Proxy @ObjectSchema))
47− `shouldBe` [("Carrier", textSchema), ("Object", objectSchema)]
48
43
49main :: IO ()
44main :: IO ()
50main = hspec spec
45main = hspec spec