git.iko.soy/typeable/schematic
on master help sign in
serialization
fceaca4Denis Redozubov
schematic.cabal+4
compare with master
unifiedsplit
@@ -18,6 +18,7 @@ cabal-version: >=1.10
18library
18library
19 exposed-modules: Data.Aeson.Validation
19 exposed-modules: Data.Aeson.Validation
20 , Data.Schematic
20 , Data.Schematic
21+ , Data.Schematic.Instances
21 , Data.Schematic.Schema
22 , Data.Schematic.Schema
22 , Data.Schematic.Utils
23 , Data.Schematic.Utils
23 -- ghc-options:
24 -- ghc-options:
@@ -60,6 +61,7 @@ library
60 , scientific
61 , scientific
61 , singletons
62 , singletons
62 , smallcheck
63 , smallcheck
64+ , smallcheck-series
63 , text
65 , text
64 , unordered-containers
66 , unordered-containers
65 , validationt >= 0.1.0.1
67 , validationt >= 0.1.0.1
@@ -108,6 +110,8 @@ test-suite spec
108 , hspec-smallcheck
110 , hspec-smallcheck
109 , regex-compat
111 , regex-compat
110 , schematic
112 , schematic
113+ , smallcheck
114+ , smallcheck-series
111 , singletons
115 , singletons
112 , text
116 , text
113 , unordered-containers
117 , unordered-containers
src/Data/Schematic/Schema.hs+73−24
@@ -16,6 +16,7 @@ import Data.Functor.Classes
16import Data.HashMap.Strict as H
16import Data.HashMap.Strict as H
17import Data.Kind
17import Data.Kind
18import Data.Maybe
18import Data.Maybe
19+import Data.Schematic.Instances
19import Data.Schematic.Utils
20import Data.Schematic.Utils
20import Data.Scientific
21import Data.Scientific
21import Data.Singletons.Decide
22import Data.Singletons.Decide
@@ -26,7 +27,9 @@ import Data.Text as T
26import Data.Vector as V
27import Data.Vector as V
27import Data.Vinyl hiding (Dict)
28import Data.Vinyl hiding (Dict)
28import Data.Vinyl.Functor
29import Data.Vinyl.Functor
30+import Data.Vinyl.TypeLevel hiding (Nat)
29import GHC.Generics (Generic)
31import GHC.Generics (Generic)
32+import Prelude as P
30import Test.SmallCheck.Series
33import Test.SmallCheck.Series
31import Text.Show.Deriving (deriveShow1)
34import Text.Show.Deriving (deriveShow1)
32
35
@@ -98,10 +101,10 @@ data Schema
98 deriving (Generic)
101 deriving (Generic)
99
102
100data instance Sing (schema :: Schema) where
103data instance Sing (schema :: Schema) where
101− SSchemaText :: Sing tcs -> Sing (SchemaText tcs)
104+ SSchemaText :: Known (Sing tcs) => Sing tcs -> Sing (SchemaText tcs)
102− SSchemaNumber :: Sing ncs -> Sing (SchemaNumber ncs)
105+ SSchemaNumber :: Known (Sing ncs) => Sing ncs -> Sing (SchemaNumber ncs)
103− SSchemaArray :: Sing acs -> Sing schema -> Sing (SchemaArray acs schema)
106+ SSchemaArray :: (Known (Sing acs), Known (Sing schema)) => Sing acs -> Sing schema -> Sing (SchemaArray acs schema)
104− SSchemaObject :: Sing fields -> Sing (SchemaObject fields)
107+ SSchemaObject :: Known (Sing fields) => Sing fields -> Sing (SchemaObject fields)
105 SSchemaNull :: Sing SchemaNull
108 SSchemaNull :: Sing SchemaNull
106
109
107instance Known (Sing sl) => Known (Sing (SchemaText sl)) where
110instance Known (Sing sl) => Known (Sing (SchemaText sl)) where
@@ -124,6 +127,12 @@ instance Eq (Sing (SchemaObject cs)) where a == b = True
124data FieldRepr :: (Symbol, Schema) -> Type where
127data FieldRepr :: (Symbol, Schema) -> Type where
125 FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
128 FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
126
129
130+type family MapSnd (cs :: [(Symbol, Schema)]) :: [Schema] where
131+ MapSnd '[] = '[]
132+ MapSnd ( '(fn, schema) ': as) = schema ': MapSnd as
133+
134+deriving instance Show (JsonRepr schema) => Show (FieldRepr '(name, schema))
135+
127instance Eq (JsonRepr schema) => Eq (FieldRepr '(name, schema)) where
136instance Eq (JsonRepr schema) => Eq (FieldRepr '(name, schema)) where
128 FieldRepr a == FieldRepr b = a == b
137 FieldRepr a == FieldRepr b = a == b
129
138
@@ -140,6 +149,39 @@ data JsonRepr :: Schema -> Type where
140 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
149 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
141 ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
150 ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
142
151
152+instance Show (JsonRepr (SchemaText cs)) where
153+ show (ReprText t) = "ReprText " P.++ show t
154+
155+instance Show (JsonRepr (SchemaNumber cs)) where
156+ show (ReprNumber n) = "ReprNumber " P.++ show n
157+
158+instance Show (JsonRepr SchemaNull) where show _ = "ReprNull"
159+
160+instance Show (JsonRepr s) => Show (JsonRepr (SchemaArray acs s)) where
161+ show (ReprArray v) = "ReprArray " P.++ show v
162+
163+instance RecAll FieldRepr fs Show => Show (JsonRepr (SchemaObject fs)) where
164+ show (ReprObject fs) = "ReprObject " P.++ show fs
165+
166+instance (Monad m, Serial m Text)
167+ => Serial m (JsonRepr (SchemaText cs)) where
168+ series = cons1 ReprText
169+
170+instance (Monad m, Serial m Scientific)
171+ => Serial m (JsonRepr (SchemaNumber cs)) where
172+ series = cons1 ReprNumber
173+
174+instance Monad m => Serial m (JsonRepr SchemaNull) where
175+ series = cons0 ReprNull
176+
177+instance (Serial m (V.Vector (JsonRepr s)))
178+ => Serial m (JsonRepr (SchemaArray cs s)) where
179+ series = cons1 ReprArray
180+
181+instance (Monad m, Serial m (Rec FieldRepr fs))
182+ => Serial m (JsonRepr (SchemaObject fs)) where
183+ series = cons1 ReprObject
184+
143instance Eq (Rec FieldRepr fs) => Eq (JsonRepr (SchemaObject fs)) where
185instance Eq (Rec FieldRepr fs) => Eq (JsonRepr (SchemaObject fs)) where
144 ReprObject a == ReprObject b = a == b
186 ReprObject a == ReprObject b = a == b
145
187
@@ -159,27 +201,34 @@ instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where
159 parseJSON value = case known :: Sing schema of
201 parseJSON value = case known :: Sing schema of
160 SSchemaText _ -> withText "String" (pure . ReprText) value
202 SSchemaText _ -> withText "String" (pure . ReprText) value
161 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
203 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
204+ SSchemaNull -> case value of
162− SSchemaNull -> pure ReprNull
205+ J.Null -> pure ReprNull
163− SSchemaArray c s -> do
206+ _ -> typeMismatch "Null" value
207+ SSchemaArray c s -> withArray "Array" (fmap ReprArray . traverse parseJSON) value
208+ SSchemaObject fs -> do
164 let
209 let
165− f :: Sing cs -> Sing s -> V.Vector J.Value -> Parser (JsonRepr (SchemaArray cs s))
166− f _ _ = fmap ReprArray . traverse parseJSON
167− withArray "Array" (f c s) value
168− SSchemaObject fs -> ReprObject <$> withObject "Object" (demoteFields fs) value
169−
170−demoteFields
171− :: SList s
172− -> H.HashMap Text J.Value
173− -> Parser (Rec FieldRepr s)
210+ demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
174−demoteFields SNil h
211+ demoteFields SNil h = pure RNil
175− | H.null h = pure RNil
176− | otherwise = mzero
177−demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
212+ demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
178− let fieldName = T.pack $ symbolVal (Proxy @fn)
213+ let fieldName = T.pack $ symbolVal (Proxy @fn)
214+ fieldRepr <- case s of
179− fieldRepr <- case H.lookup fieldName h of
215+ SSchemaText _ -> case H.lookup fieldName h of
180− Just v -> FieldRepr <$> (withSingI s $ parseJSON v)
216+ Just v -> FieldRepr <$> parseJSON v
217+ Nothing -> fail "schematext"
218+ SSchemaNumber _ -> case H.lookup fieldName h of
219+ Just v -> FieldRepr <$> parseJSON v
181− Nothing -> mzero
220+ Nothing -> fail "schemanumber"
221+ SSchemaNull -> case H.lookup fieldName h of
222+ Just v -> FieldRepr <$> parseJSON v
223+ Nothing -> fail "schemanull"
224+ SSchemaArray _ _ -> case H.lookup fieldName h of
225+ Just v -> FieldRepr <$> parseJSON v
226+ Nothing -> fail "schemaarray"
227+ SSchemaObject _ -> case H.lookup fieldName h of
228+ Just v -> FieldRepr <$> parseJSON v
229+ Nothing -> fail "schemaobject"
182− (fieldRepr :&) <$> demoteFields tl h
230+ (fieldRepr :&) <$> demoteFields tl h
231+ ReprObject <$> withObject "Object" (demoteFields fs) value
183
232
184instance J.ToJSON (JsonRepr a) where
233instance J.ToJSON (JsonRepr a) where
185 toJSON ReprNull = J.Null
234 toJSON ReprNull = J.Null
src/Data/Schematic/Utils.hsnew file+37
@@ -0,0 +1,37 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+
3+module Data.Schematic.Utils where
4+
5+import Data.Kind
6+import Data.Proxy
7+import Data.Singletons
8+import Data.Singletons.Prelude
9+import Data.Singletons.TypeLits
10+import Data.Vinyl hiding (Dict)
11+
12+
13+class Known a where
14+ known :: a
15+
16+instance KnownNat n => Known (Sing n) where
17+ known = SNat
18+
19+instance KnownSymbol s => Known (Sing s) where
20+ known = SSym
21+
22+instance (Known (Sing a), Known (Sing b)) => Known (Sing '(a,b)) where
23+ known = STuple2 known known
24+
25+instance Known (Sing '[]) where known = SNil
26+
27+instance (Known (Sing a), Known (Sing as)) => Known (Sing (a ': as)) where
28+ known = SCons known known
29+
30+instance Known (Rec Sing '[]) where
31+ known = RNil
32+
33+instance (Known (Sing a), Known (Rec Sing tl)) => Known (Rec Sing (a ': tl)) where
34+ known = known :& known
35+
36+data Dict c where
37+ Dict :: c => Dict c
stack.yaml+1−16
@@ -1,19 +1,3 @@
1−# This file was automatically generated by 'stack init'
2−#
3−# Some commonly used options have been documented as comments in this file.
4−# For advanced use and comprehensive documentation of the format, please see:
5−# http://docs.haskellstack.org/en/stable/yaml_configuration/
6−
7−# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8−# A snapshot resolver dictates the compiler version and the set of packages
9−# to be used for project dependencies. For example:
10−#
11−# resolver: lts-3.5
12−# resolver: nightly-2015-09-21
13−# resolver: ghcjs-0.1.0_ghc-7.10.2
14−# resolver:
15−# name: custom-snapshot
16−# location: "./custom-snapshot.yaml"
17resolver: lts-8.12
1resolver: lts-8.12
18#resolver: ghc-8.0.2
2#resolver: ghc-8.0.2
19
3
@@ -43,6 +27,7 @@ packages:
43
27
44extra-deps:
28extra-deps:
45- validationt-0.2.0.0
29- validationt-0.2.0.0
30+- smallcheck-series-0.6
46
31
47# Override default flag values for local packages and extra-deps
32# Override default flag values for local packages and extra-deps
48flags: {}
33flags: {}
test/SchemaSpec.hs+21−23
@@ -1,5 +1,6 @@
1module SchemaSpec (spec, main) where
1module SchemaSpec (spec, main) where
2
2
3+import Control.Monad
3import Data.Aeson
4import Data.Aeson
4import Data.Proxy
5import Data.Proxy
5import Data.Schematic
6import Data.Schematic
@@ -7,45 +8,42 @@ import Data.Singletons
7import Data.Vinyl
8import Data.Vinyl
8import Test.Hspec
9import Test.Hspec
9import Test.Hspec.SmallCheck
10import Test.Hspec.SmallCheck
11+import Test.SmallCheck
12+import Test.SmallCheck.Series.Instances
10
13
11
14
12type SchemaExample
15type SchemaExample
13 = SchemaObject
16 = SchemaObject
14− '[ '("foo", SchemaArray '[AEq 3] (SchemaNumber '[NGt 10]))
17+ '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
15 , '("bar", SchemaText '[TRegex "\\w+"])]
18 , '("bar", SchemaText '[TRegex "\\w+"])]
16
19
17−schemaExample
18− :: ( DemoteRep Schema ~ Sing SchemaExample
19− , DemoteRep Schema ~ s
20− , SingKind Schema
21− , SingI SchemaExample
22− ) => s
23−schemaExample = fromSing (sing :: Sing SchemaExample)
24−
25exampleTest :: JsonRepr (SchemaText '[TEq 3])
20exampleTest :: JsonRepr (SchemaText '[TEq 3])
26−exampleTest = ReprText "lilo"
21+exampleTest = ReprText "lil"
27
22
28−exampleNumber :: JsonRepr (SchemaNumber '[NEq 3])
23+exampleNumber :: JsonRepr (SchemaNumber '[NGt 10])
29−exampleNumber = ReprNumber 3
24+exampleNumber = ReprNumber 12
30
25
31−exampleArray :: JsonRepr (SchemaArray '[AEq 1] (SchemaNumber '[NEq 3]))
26+exampleArray :: JsonRepr (SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))
32exampleArray = ReprArray [exampleNumber]
27exampleArray = ReprArray [exampleNumber]
33
28
34−exampleObject
29+exampleObject :: JsonRepr SchemaExample
35− :: JsonRepr (SchemaObject '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NEq 3]))] )
36−exampleObject = ReprObject $ FieldRepr exampleArray :& RNil
30+exampleObject = ReprObject $ FieldRepr exampleArray :& FieldRepr (ReprText "barval") :& RNil
37
31
38−example :: JsonRepr SchemaExample
32+jsonExample :: JsonRepr SchemaExample
39−example = ReprObject $
33+jsonExample = ReprObject $
40− FieldRepr (ReprArray [ReprNumber 3])
34+ FieldRepr (ReprArray [ReprNumber 12])
41− :& FieldRepr (ReprText "test")
35+ :& FieldRepr (ReprText "tes")
42 :& RNil
36 :& RNil
43
37
38+-- schemaExample :: Sing SchemaExample
39+-- schemaExample = known
40+
44spec :: Spec
41spec :: Spec
45spec = do
42spec = do
43+ -- it "show/read JsonRepr properly" $
44+ -- read (show example) == example
46− it "decode/encode JsonRepr properly" $ do
45+ it "decode/encode JsonRepr properly" $
47− withSingI schemaExample $ property
48− $ \(a :: JsonRepr SchemaExample) -> decode (encode a) == Just a
46+ decode (encode jsonExample) == Just jsonExample
49
47
50main :: IO ()
48main :: IO ()
51main = hspec spec
49main = hspec spec