git.iko.soy/schematic
on master help sign in
WIP
6d93ae2Denis Redozubov
schematic.cabal+4−2
compare with master
unifiedsplit
@@ -63,9 +63,10 @@ library
63 , bytestring
63 , bytestring
64 , aeson >= 1
64 , aeson >= 1
65 , containers
65 , containers
66+ , hjsonschema
66 , regex-compat
67 , regex-compat
67 , scientific
68 , scientific
68− , singletons
69+ , singletons >= 2.2
69 , smallcheck
70 , smallcheck
70 , smallcheck-series
71 , smallcheck-series
71 , tagged
72 , tagged
@@ -113,6 +114,7 @@ test-suite spec
113 , base >=4.9 && <4.10
114 , base >=4.9 && <4.10
114 , bytestring
115 , bytestring
115 , containers
116 , containers
117+ , hjsonschema
116 , hspec >= 2.2.0
118 , hspec >= 2.2.0
117 , hspec-core
119 , hspec-core
118 , hspec-discover
120 , hspec-discover
@@ -122,7 +124,7 @@ test-suite spec
122 , schematic
124 , schematic
123 , smallcheck
125 , smallcheck
124 , smallcheck-series
126 , smallcheck-series
125− , singletons
127+ , singletons >= 2.3.1
126 , tagged
128 , tagged
127 , text
129 , text
128 , unordered-containers
130 , unordered-containers
src/Data/Schematic/JsonSchema.hs+33−51
@@ -1,3 +1,4 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE OverloadedLabels #-}
3{-# LANGUAGE OverloadedLabels #-}
3
4
@@ -6,58 +7,39 @@ module Data.Schematic.JsonSchema where
6import Data.Aeson
7import Data.Aeson
7import qualified Data.Map as M
8import qualified Data.Map as M
8import Data.Schematic.Schema
9import Data.Schematic.Schema
10+import Data.Singletons
9import Data.Text
11import Data.Text
10−
12+import qualified JSONSchema.Draft4.Schema as D4
11−
13+
14+
12−draft6 :: Text
15+draft4 :: Text
13−draft6 = "http://json-schema.org/draft-06/schema#"
16+draft4 = "http://json-schema.org/draft-04/schema#"
14−
17+
15−data JsonSchemaType
18+-- toJsonSchema :: JsonRepr schema -> D4.Schema
16− = JObject
19+-- toJsonSchema (ReprText t) = D4.emptySchema
17− | JArray
20+-- { D4._schemaVersion = pure draft4
18− | JNumber
21+-- }
19− | JString
22+
20− | JNull
23+toJsonSchema
21−
24+ :: forall schema. (SingI schema)
22−instance ToJSON JsonSchemaType where
25+ => Sing (schema :: Schema)
23− toJSON JObject = "object"
26+ -> D4.Schema
24− toJSON JArray = "array"
27+toJsonSchema _ = case fromSing (sing :: Sing schema) of
25− toJSON JNumber = "number"
28+ SchemaText tcs -> D4.emptySchema
26− toJSON JString = "string"
29+ SchemaNumber ncs -> D4.emptySchema
27− toJSON JNull = "null"
30+ SchemaObject ocs -> D4.emptySchema
28−
31+ SchemaArray acs sch -> D4.emptySchema
29−data JsonSchema
32+ SchemaNull -> D4.emptySchema
30− = RootSchema
33+ SchemaOptional sch -> D4.emptySchema
31− { type_ :: JsonSchemaType
34+
32− , title :: Text
33− , items :: Maybe Text
34− , schemaDraft :: Text }
35− | JsonObject
36− { type_ :: JsonSchemaType
37− , properties :: M.Map Text JsonSchema
38− , additionalProperties :: Bool
39− , required :: [Text]
40− , schemaDraft :: Text }
41− | JsonOptional JsonSchema
42−
43−jsonObject :: M.Map Text JsonSchema -> JsonSchema
35+-- jsonObject :: M.Map Text JsonSchema -> JsonSchema
44−jsonObject m = JsonObject
36+-- jsonObject m = JsonObject
45− { type_ = JObject
37+-- { type_ = JObject
46− , properties = m
38+-- , properties = m
47− , additionalProperties = False
39+-- , additionalProperties = False
48− , required = M.keys $ M.filter
40+-- , required = M.keys $ M.filter
49− (\case; JsonOptional _ -> False; _ -> True) m
41+-- (\case; JsonOptional _ -> False; _ -> True) m
50− , schemaDraft = draft6 }
42+-- , schemaDraft = draft6 }
51−
52−instance ToJSON JsonSchema where
53− toJSON RootSchema{..} = object [ "type" .= type_, "title" .= title ]
54− toJSON JsonObject{..} =
55− object
56− [ "type" .= type_
57− , "properties" .= properties
58− , "additionalProperties" .= additionalProperties
59− , "required" .= required
60− , "schemaDraft" .= schemaDraft]
61
43
62-- Root schema:
44-- Root schema:
63--
45--
src/Data/Schematic/Schema.hs+78
@@ -46,6 +46,17 @@ data TextConstraint
46 | TEnum [Symbol]
46 | TEnum [Symbol]
47 deriving (Generic)
47 deriving (Generic)
48
48
49+
50+data DemotedTextConstraint
51+ = DTEq Integer
52+ | DTLt Integer
53+ | DTLe Integer
54+ | DTGt Integer
55+ | DTGe Integer
56+ | DTRegex Text
57+ | DTEnum [Text]
58+ deriving (Generic)
59+
49data instance Sing (tc :: TextConstraint) where
60data instance Sing (tc :: TextConstraint) where
50 STEq :: Sing n -> Sing ('TEq n)
61 STEq :: Sing n -> Sing ('TEq n)
51 STLt :: Sing n -> Sing ('TLt n)
62 STLt :: Sing n -> Sing ('TLt n)
@@ -79,6 +90,14 @@ data NumberConstraint
79 | NEq Nat
90 | NEq Nat
80 deriving (Generic)
91 deriving (Generic)
81
92
93+data DemotedNumberConstraint
94+ = DNLe Integer
95+ | DNLt Integer
96+ | DNGt Integer
97+ | DNGe Integer
98+ | DNEq Integer
99+ deriving (Generic)
100+
82data instance Sing (nc :: NumberConstraint) where
101data instance Sing (nc :: NumberConstraint) where
83 SNEq :: Sing n -> Sing ('NEq n)
102 SNEq :: Sing n -> Sing ('NEq n)
84 SNGt :: Sing n -> Sing ('NGt n)
103 SNGt :: Sing n -> Sing ('NGt n)
@@ -102,6 +121,10 @@ data ArrayConstraint
102 = AEq Nat
121 = AEq Nat
103 deriving (Generic)
122 deriving (Generic)
104
123
124+data DemotedArrayConstraint
125+ = DAEq Integer
126+ deriving (Generic)
127+
105data instance Sing (ac :: ArrayConstraint) where
128data instance Sing (ac :: ArrayConstraint) where
106 SAEq :: Sing n -> Sing ('AEq n)
129 SAEq :: Sing n -> Sing ('AEq n)
107
130
@@ -118,6 +141,15 @@ data Schema
118 | SchemaOptional Schema
141 | SchemaOptional Schema
119 deriving (Generic)
142 deriving (Generic)
120
143
144+data DemotedSchema
145+ = DSchemaText [DemotedTextConstraint]
146+ | DSchemaNumber [DemotedNumberConstraint]
147+ | DSchemaObject [(Text, DemotedSchema)]
148+ | DSchemaArray [DemotedArrayConstraint] DemotedSchema
149+ | DSchemaNull
150+ | DSchemaOptional DemotedSchema
151+ deriving (Generic)
152+
121data instance Sing (schema :: Schema) where
153data instance Sing (schema :: Schema) where
122 SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)
154 SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)
123 SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)
155 SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)
@@ -146,6 +178,52 @@ instance Eq (Sing ('SchemaArray as s)) where _ == _ = True
146instance Eq (Sing ('SchemaObject cs)) where _ == _ = True
178instance Eq (Sing ('SchemaObject cs)) where _ == _ = True
147instance Eq (Sing ('SchemaOptional s)) where _ == _ = True
179instance Eq (Sing ('SchemaOptional s)) where _ == _ = True
148
180
181+-- | One-way 'SingKind` variation
182+-- class SingKind' k where
183+-- type DemoteRep' k :: *
184+-- fromSing' :: Sing (a :: k) -> DemoteRep' k
185+
186+-- instance SingKind' TextConstraint where
187+-- type DemoteRep' TextConstraint = DemotedTextConstraint
188+-- fromSing' = \case
189+-- STEq n -> withKnownNat n (DTEq $ natVal n)
190+-- STLt n -> withKnownNat n (DTLt $ natVal n)
191+-- STLe n -> withKnownNat n (DTLe $ natVal n)
192+-- STGt n -> withKnownNat n (DTGt $ natVal n)
193+-- STGe n -> withKnownNat n (DTGe $ natVal n)
194+-- STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s)
195+-- STEnum s -> let
196+-- d :: Sing (s :: [Symbol]) -> [Text]
197+-- d SNil = []
198+-- d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs
199+-- in DTEnum $ d s
200+
201+-- instance SingKind' NumberConstraint where
202+-- type DemoteRep' NumberConstraint = DemotedNumberConstraint
203+-- fromSing' = \case
204+-- SNLe n -> withKnownNat n (DNLe $ natVal n)
205+-- SNLt n -> withKnownNat n (DNLt $ natVal n)
206+-- SNGe n -> withKnownNat n (DNGe $ natVal n)
207+-- SNGt n -> withKnownNat n (DNGt $ natVal n)
208+-- SNEq n -> withKnownNat n (DNEq $ natVal n)
209+
210+-- instance SingKind' ArrayConstraint where
211+-- type DemoteRep' ArrayConstraint = DemotedArrayConstraint
212+-- fromSing' = \case
213+-- SAEq n -> withKnownNat n (DAEq $ natVal n)
214+
215+-- instance SingKind' Schema where
216+-- type DemoteRep' Schema = DemotedSchema
217+-- fromSing' = \case
218+-- SSchemaText tcs -> DSchemaText $ fromSing' tcs
219+ -- SchemaText [TextConstraint]
220+ -- SchemaNumber [NumberConstraint]
221+ -- SchemaObject [(Symbol, Schema)]
222+ -- SchemaArray [ArrayConstraint] Schema
223+ -- SchemaNull
224+ -- SchemaOptional Schema
225+
226+
149data FieldRepr :: (Symbol, Schema) -> Type where
227data FieldRepr :: (Symbol, Schema) -> Type where
150 FieldRepr
228 FieldRepr
151 :: (SingI schema, KnownSymbol name)
229 :: (SingI schema, KnownSymbol name)