@@ -0,0 +1,78 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE OverloadedLabels #-}
3+
4+module Data.Schematic.JsonSchema where
5+
6+import Data.Aeson
7+import qualified Data.Map as M
8+import Data.Schematic.Schema
9+import Data.Text
10+
11+
12+draft6 :: Text
13+draft6 = "http://json-schema.org/draft-06/schema#"
14+
15+data JsonSchemaType
16+ = JObject
17+ | JArray
18+ | JNumber
19+ | JString
20+ | JNull
21+
22+instance ToJSON JsonSchemaType where
23+ toJSON JObject = "object"
24+ toJSON JArray = "array"
25+ toJSON JNumber = "number"
26+ toJSON JString = "string"
27+ toJSON JNull = "null"
28+
29+data JsonSchema
30+ = RootSchema
31+ { type_ :: JsonSchemaType
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
44+jsonObject m = JsonObject
45+ { type_ = JObject
46+ , properties = m
47+ , additionalProperties = False
48+ , required = M.keys $ M.filter
49+ (\case; JsonOptional _ -> False; _ -> True) m
50+ , 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+
62+-- Root schema:
63+--
64+-- {
65+-- "title": "root",
66+-- "items": {
67+-- "title": "array item"
68+-- }
69+-- }
70+
71+-- toSchema :: JsonRepr a -> JsonSchema
72+-- toSchema = \case
73+-- ReprText t ->
74+-- ReprNumber n ->
75+-- ReprNull ->
76+-- ReprArray arr ->
77+-- ReprObject obj ->
78+-- ReprOptional mv ->