6d93ae2 · schematic · git.iko.soy

git.iko.soy/schematic

WIP

commit6d93ae2d83f4481354b25fcf33b1384dc67040b1 authorDenis Redozubov <denis.redozubov@gmail.com> dateWed 30 Aug 2017, 14:19 (9 years ago) parentd1c4a61

3 files changed+115−53

compare with master

unifiedsplit

schematic.cabal+4−2 src/Data/Schematic/JsonSchema.hs+33−51 src/Data/Schematic/Schema.hs+78

schematic.cabal+4−2

@@ -63,9 +63,10 @@ library

6363 , bytestring

6464 , aeson >= 1

6565 , containers

66+ , hjsonschema

6667 , regex-compat

6768 , scientific

68− , singletons

69+ , singletons >= 2.2

6970 , smallcheck

7071 , smallcheck-series

7172 , tagged

@@ -113,6 +114,7 @@ test-suite spec

113114 , base >=4.9 && <4.10

114115 , bytestring

115116 , containers

117+ , hjsonschema

116118 , hspec >= 2.2.0

117119 , hspec-core

118120 , hspec-discover

@@ -122,7 +124,7 @@ test-suite spec

122124 , schematic

123125 , smallcheck

124126 , smallcheck-series

125− , singletons

127+ , singletons >= 2.3.1

126128 , tagged

127129 , text

128130 , unordered-containers

src/Data/Schematic/JsonSchema.hs+33−51

@@ -1,3 +1,4 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

12{-# LANGUAGE RecordWildCards #-}

23{-# LANGUAGE OverloadedLabels #-}

@@ -6,58 +7,39 @@ module Data.Schematic.JsonSchema where

67import Data.Aeson

78import qualified Data.Map as M

89import Data.Schematic.Schema

10+import Data.Singletons

911import 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]

12+import qualified JSONSchema.Draft4.Schema as D4

13+

14+

15+draft4 :: Text

16+draft4 = "http://json-schema.org/draft-04/schema#"

17+

18+-- toJsonSchema :: JsonRepr schema -> D4.Schema

19+-- toJsonSchema (ReprText t) = D4.emptySchema

20+-- { D4._schemaVersion = pure draft4

21+-- }

22+

23+toJsonSchema

24+ :: forall schema. (SingI schema)

25+ => Sing (schema :: Schema)

26+ -> D4.Schema

27+toJsonSchema _ = case fromSing (sing :: Sing schema) of

28+ SchemaText tcs -> D4.emptySchema

29+ SchemaNumber ncs -> D4.emptySchema

30+ SchemaObject ocs -> D4.emptySchema

31+ SchemaArray acs sch -> D4.emptySchema

32+ SchemaNull -> D4.emptySchema

33+ SchemaOptional sch -> D4.emptySchema

34+

35+-- jsonObject :: M.Map Text JsonSchema -> JsonSchema

36+-- jsonObject m = JsonObject

37+-- { type_ = JObject

38+-- , properties = m

39+-- , additionalProperties = False

40+-- , required = M.keys $ M.filter

41+-- (\case; JsonOptional _ -> False; _ -> True) m

42+-- , schemaDraft = draft6 }

6143

6244-- Root schema:

6345--

src/Data/Schematic/Schema.hs+78

@@ -46,6 +46,17 @@ data TextConstraint

4646 | TEnum [Symbol]

4747 deriving (Generic)

4848

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+

4960data instance Sing (tc :: TextConstraint) where

5061 STEq :: Sing n -> Sing ('TEq n)

5162 STLt :: Sing n -> Sing ('TLt n)

@@ -79,6 +90,14 @@ data NumberConstraint

7990 | NEq Nat

8091 deriving (Generic)

8192

93+data DemotedNumberConstraint

94+ = DNLe Integer

95+ | DNLt Integer

96+ | DNGt Integer

97+ | DNGe Integer

98+ | DNEq Integer

99+ deriving (Generic)

100+

82101data instance Sing (nc :: NumberConstraint) where

83102 SNEq :: Sing n -> Sing ('NEq n)

84103 SNGt :: Sing n -> Sing ('NGt n)

@@ -102,6 +121,10 @@ data ArrayConstraint

102121 = AEq Nat

103122 deriving (Generic)

104123

124+data DemotedArrayConstraint

125+ = DAEq Integer

126+ deriving (Generic)

127+

105128data instance Sing (ac :: ArrayConstraint) where

106129 SAEq :: Sing n -> Sing ('AEq n)

107130

@@ -118,6 +141,15 @@ data Schema

118141 | SchemaOptional Schema

119142 deriving (Generic)

120143

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+

121153data instance Sing (schema :: Schema) where

122154 SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)

123155 SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)

@@ -146,6 +178,52 @@ instance Eq (Sing ('SchemaArray as s)) where _ == _ = True

146178instance Eq (Sing ('SchemaObject cs)) where _ == _ = True

147179instance Eq (Sing ('SchemaOptional s)) where _ == _ = True

148180

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+

149227data FieldRepr :: (Symbol, Schema) -> Type where

150228 FieldRepr

151229 :: (SingI schema, KnownSymbol name)