git.iko.soy/typeable/schematic
on master help sign in
wip type-generation tags
commit7dd75d374b7b28f6cad6a3aa0135b2f0ca22152f authorDenis Redozubov <denis.redozubov@gmail.com> dateWed 10 May 2017, 00:26 (9 years ago) parentc73af44
3 files changed+72−11
compare with master
unifiedsplit
schematic.cabal+3 src/Data/Schematic/Schema.hs+35−4 test/SchemaSpec.hs+34−7
schematic.cabal+3
@@ -51,6 +51,8 @@ library
5151 , TypeSynonymInstances
5252 , UndecidableInstances
5353 build-depends: base >=4.9 && <4.10
54+ , deriving-compat
55+ , recursion-schemes
5456 , regex-compat
5557 , singletons
5658 , text
@@ -92,6 +94,7 @@ test-suite spec
9294 , hspec >= 2.2.0
9395 , hspec-core
9496 , hspec-discover
97+ , recursion-schemes
9598 , regex-compat
9699 , schematic
97100 , text
src/Data/Schematic/Schema.hs+35−4
@@ -6,10 +6,12 @@
66
77module Data.Schematic.Schema where
88
9+import Data.Functor.Foldable
910import Data.Kind hiding (Type)
1011import Data.Proxy
1112import Data.Schematic.Validation
1213import Data.Text (Text)
14+import GHC.Generics
1315import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
1416
1517
@@ -79,13 +81,13 @@ class SchemaConstructor jty where
7981 constructor :: Proxy jty -> [CRepr jty] -> Schema
8082
8183instance SchemaConstructor 'JText where
82− constructor _ = SchemaText SJText
84+ constructor _ = Fix . SchemaText SJText
8385
8486instance SchemaConstructor 'JNumber where
85− constructor _ = SchemaNumber SJNumber
87+ constructor _ = Fix . SchemaNumber SJNumber
8688
8789instance SchemaConstructor 'JObject where
88− constructor _ = SchemaObject SJObject
90+ constructor _ = Fix . SchemaObject SJObject
8991
9092class Schematic ty where
9193 type JT (ty :: k) :: JType
@@ -128,11 +130,40 @@ instance
128130 => Schematic (SArray cs s) where
129131 type JT (SArray cs s) = 'JArray
130132 build _ =
131− SchemaArray
133+ Fix $ SchemaArray
132134 SJArray
133135 (schema (Proxy @'JArray) (Proxy @cs))
134136 (build (Proxy @s))
135137
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+
136167-- | Shows it's top-level definition according to the json-schema
137168class TopLevel spec
138169
test/SchemaSpec.hs+34−7
@@ -1,9 +1,12 @@
11module SchemaSpec (spec, main) where
22
3+import Data.Functor.Foldable
34import Data.Proxy
45import Data.Schematic.Schema
6+import Data.Schematic.Validation
57import Test.Hspec
68
9+
710type TextSchema = SText '[LengthEqNat 2]
811
912type NumberSchema = SNumber '[ Gt 3]
@@ -11,15 +14,33 @@ type NumberSchema = SNumber '[ Gt 3]
1114type ArraySchema = SArray '[ LengthEqNat 3 ] NumberSchema
1215
1316type ObjectSchema
14− = SObject '[ Field "carrier" 'JText '[LengthEqNat 2], Field "number_gt_3" 'JNumber '[Gt 3] ]
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])
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] ])
1531
1632spec :: Spec
1733spec = 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+
1843 describe "Schema translation: " $ do
19− let
20− textSchema = SchemaText [LengthEq 2]
21− numberSchema = SchemaNumber [Gt 3]
22− arraySchema = SchemaArray [LengthArrEq 3] $ SchemaNumber [Gt 3]
2344 it "translate string schema"
2445 $ build (Proxy @TextSchema) `shouldBe` textSchema
2546 it "translates number schema"
@@ -27,8 +48,14 @@ spec = do
2748 it "translates array schema" $ do
2849 build (Proxy @ArraySchema) `shouldBe` arraySchema
2950 it "translates object schema" $ do
30− build (Proxy @ObjectSchema) `shouldBe`
31− SchemaObject [("carrier", textSchema), ("number_gt_3", numberSchema)]
51+ build (Proxy @ObjectSchema) `shouldBe` objectSchema
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)]
3259
3360main :: IO ()
3461main = hspec spec