git.iko.soy/typeable/schematic
on master help sign in
wip type-generation tags
7dd75d3Denis Redozubov
schematic.cabal+3
compare with master
unifiedsplit
@@ -51,6 +51,8 @@ library
51 , TypeSynonymInstances
51 , TypeSynonymInstances
52 , UndecidableInstances
52 , UndecidableInstances
53 build-depends: base >=4.9 && <4.10
53 build-depends: base >=4.9 && <4.10
54+ , deriving-compat
55+ , recursion-schemes
54 , regex-compat
56 , regex-compat
55 , singletons
57 , singletons
56 , text
58 , text
@@ -92,6 +94,7 @@ test-suite spec
92 , hspec >= 2.2.0
94 , hspec >= 2.2.0
93 , hspec-core
95 , hspec-core
94 , hspec-discover
96 , hspec-discover
97+ , recursion-schemes
95 , regex-compat
98 , regex-compat
96 , schematic
99 , schematic
97 , text
100 , text
src/Data/Schematic/Schema.hs+35−4
@@ -6,10 +6,12 @@
6
6
7module Data.Schematic.Schema where
7module Data.Schematic.Schema where
8
8
9+import Data.Functor.Foldable
9import Data.Kind hiding (Type)
10import Data.Kind hiding (Type)
10import Data.Proxy
11import Data.Proxy
11import Data.Schematic.Validation
12import Data.Schematic.Validation
12import Data.Text (Text)
13import Data.Text (Text)
14+import GHC.Generics
13import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
15import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
14
16
15
17
@@ -79,13 +81,13 @@ class SchemaConstructor jty where
79 constructor :: Proxy jty -> [CRepr jty] -> Schema
81 constructor :: Proxy jty -> [CRepr jty] -> Schema
80
82
81instance SchemaConstructor 'JText where
83instance SchemaConstructor 'JText where
82− constructor _ = SchemaText SJText
84+ constructor _ = Fix . SchemaText SJText
83
85
84instance SchemaConstructor 'JNumber where
86instance SchemaConstructor 'JNumber where
85− constructor _ = SchemaNumber SJNumber
87+ constructor _ = Fix . SchemaNumber SJNumber
86
88
87instance SchemaConstructor 'JObject where
89instance SchemaConstructor 'JObject where
88− constructor _ = SchemaObject SJObject
90+ constructor _ = Fix . SchemaObject SJObject
89
91
90class Schematic ty where
92class Schematic ty where
91 type JT (ty :: k) :: JType
93 type JT (ty :: k) :: JType
@@ -128,11 +130,40 @@ instance
128 => Schematic (SArray cs s) where
130 => Schematic (SArray cs s) where
129 type JT (SArray cs s) = 'JArray
131 type JT (SArray cs s) = 'JArray
130 build _ =
132 build _ =
131− SchemaArray
133+ Fix $ SchemaArray
132 SJArray
134 SJArray
133 (schema (Proxy @'JArray) (Proxy @cs))
135 (schema (Proxy @'JArray) (Proxy @cs))
134 (build (Proxy @s))
136 (build (Proxy @s))
135
137
138+data Generate name ty
139+
140+instance
141+ ( Verifiable JText cs
142+ , KnownSymbol name, Schematic ty )
143+ => Schematic (Generate name (SText cs)) where
144+ type JT (Generate name (SText cs)) = JT (SText cs)
145+ build _ = build (Proxy @(SText cs))
146+
147+instance
148+ ( Verifiable JNumber cs
149+ , KnownSymbol name, Schematic ty )
150+ => Schematic (Generate name (SNumber cs)) where
151+ type JT (Generate name (SNumber cs)) = JT (SNumber cs)
152+ build _ = build (Proxy @(SNumber cs))
153+
154+instance
155+ ( Verifiable JArray cs
156+ , Schematic s )
157+ => Schematic (Generate name (SArray cs s)) where
158+ type JT (Generate name (SArray cs s)) = JT (SArray cs s)
159+ build _ = build (Proxy @(SArray cs s))
160+
161+instance
162+ (Verifiable JObject els)
163+ => Schematic (Generate name (SObject els)) where
164+ type JT (Generate name (SObject els)) = JT (SObject els)
165+ build _ = build (Proxy @(SObject els))
166+
136-- | Shows it's top-level definition according to the json-schema
167-- | Shows it's top-level definition according to the json-schema
137class TopLevel spec
168class TopLevel spec
138
169
test/SchemaSpec.hs+34−7
@@ -1,9 +1,12 @@
1module SchemaSpec (spec, main) where
1module SchemaSpec (spec, main) where
2
2
3+import Data.Functor.Foldable
3import Data.Proxy
4import Data.Proxy
4import Data.Schematic.Schema
5import Data.Schematic.Schema
6+import Data.Schematic.Validation
5import Test.Hspec
7import Test.Hspec
6
8
9+
7type TextSchema = SText '[LengthEqNat 2]
10type TextSchema = SText '[LengthEqNat 2]
8
11
9type NumberSchema = SNumber '[ Gt 3]
12type NumberSchema = SNumber '[ Gt 3]
@@ -11,15 +14,33 @@ type NumberSchema = SNumber '[ Gt 3]
11type ArraySchema = SArray '[ LengthEqNat 3 ] NumberSchema
14type ArraySchema = SArray '[ LengthEqNat 3 ] NumberSchema
12
15
13type ObjectSchema
16type ObjectSchema
17+ = SObject
18+ '[ Field "carrier" 'JText '[LengthEqNat 2]
19+ , Field "number_gt_3" 'JNumber '[Gt 3] ]
20+
21+type GeneratorSchema
22+ = SObject
23+ '[ Generate "Carrier" (Field "carrier" 'JText '[LengthEqNat 2])
14− = SObject '[ Field "carrier" 'JText '[LengthEqNat 2], Field "number_gt_3" 'JNumber '[Gt 3] ]
24+ , Field "number_gt_3" 'JNumber '[Gt 3] ]
25+
26+type BiggerSchema
27+ = Generate "Object"
28+ ( SObject
29+ '[ Generate "Carrier" (Field "carrier" 'JText '[LengthEqNat 2])
30+ , Field "number_gt_3" 'JNumber '[Gt 3] ])
15
31
16spec :: Spec
32spec :: Spec
17spec = do
33spec = do
34+ let
35+ textSchema = Fix $ SchemaText SJText [LengthEq 2]
36+ numberSchema = Fix $ SchemaNumber SJNumber [Gt 3]
37+ arraySchema = Fix $ SchemaArray SJArray [LengthArrEq 3]
38+ $ Fix $ SchemaNumber SJNumber [Gt 3]
39+ objectSchema = Fix $ SchemaObject SJObject
40+ [ ("carrier", textSchema)
41+ , ("number_gt_3", numberSchema)]
42+
18 describe "Schema translation: " $ do
43 describe "Schema translation: " $ do
19− let
20− textSchema = SchemaText [LengthEq 2]
21− numberSchema = SchemaNumber [Gt 3]
22− arraySchema = SchemaArray [LengthArrEq 3] $ SchemaNumber [Gt 3]
23 it "translate string schema"
44 it "translate string schema"
24 $ build (Proxy @TextSchema) `shouldBe` textSchema
45 $ build (Proxy @TextSchema) `shouldBe` textSchema
25 it "translates number schema"
46 it "translates number schema"
@@ -27,8 +48,14 @@ spec = do
27 it "translates array schema" $ do
48 it "translates array schema" $ do
28 build (Proxy @ArraySchema) `shouldBe` arraySchema
49 build (Proxy @ArraySchema) `shouldBe` arraySchema
29 it "translates object schema" $ do
50 it "translates object schema" $ do
30− build (Proxy @ObjectSchema) `shouldBe`
51+ build (Proxy @ObjectSchema) `shouldBe` objectSchema
31− SchemaObject [("carrier", textSchema), ("number_gt_3", numberSchema)]
52+ it "translates Generate symbols" $ do
53+ build (Proxy @GeneratorSchema) `shouldBe` objectSchema
54+
55+ describe "Types listing: " $ do
56+ it "lists types"
57+ $ typesOf (build (Proxy @BiggerSchema))
58+ `shouldBe` [("Carrier", textSchema), ("Object", objectSchema)]
32
59
33main :: IO ()
60main :: IO ()
34main = hspec spec
61main = hspec spec