master...227fe18 · typeable/schematic

git.iko.soy/typeable/schematic

README.md+16−15

since splitsnapshots

@@ -6,10 +6,10 @@

7The goal of the library is to provide a type-safe transport layer for serializing and validating JSON. It can be thought of as a subset of [json-schema](http://json-schema.org), which is basically a specification of a JSON document. The other goal is getting as much as possible from this specification for free. Right now the following bits are prototyped:

9−* All the instantiations of transport types are structurally follow the schema provided by user

9+* All of the instantiations of the transport types structurally follow the schema provided by user

10−* Serializers are generic, so they follow from the type-level schema and the're supposed to have roundtrip property by implementation.

10+* Serializers are generic, so they follow from the type-level schema and the're supposed to have a roundtrip property by an implementation.

11* Runtime value validators are generated from the schema. Validation errors are reported as a pairs of a json-path to the element and an error message.

12−* There are migrations. It's possible to describe a series of migrations to the schema and have all the machinery deserialize a user specified version of the schema if there's a few versions.

12+* There are migrations. It's possible to describe a series of migrations to the schema and have all the necessary machinery to deserialize a user specified version of the schema if there's a few versions.

14## TODO

@@ -37,13 +37,13 @@ type SchemaExample

37 , '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]

38```

40−* This schema says that's structurally it's a JSON object which has two field:

40+* This schema says that's structurally it's a JSON object which has two fields:

41− * field "foo" contains an of numeric values

41+ * field "foo" contains an array of numeric values

42− * field "bar" contains an optional textual value

42+ * field "bar" contains an optional text value

43−* It also allows you to validate the JSON:

43+* It also allows you to validate JSON values itself:

44− * an array in "foo" must contain exactly one element

44+ * an array in "foo" contains exactly one element

45 * that element must be strictly greater than 10

46− * value of bar must be either "foo" or "bar" if presented

46+ * value of "bar" field must be either "foo" or "bar" if presented

49This one is valid for example

@@ -67,11 +67,12 @@ decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)

67```

69`ParseResult` type encodes three possible situations:

70−* json is structurally consistent with schema and runtime validations passed

70+* json is structurally consistent with a schema and runtime validations pass

71−* json source is malformed or doesn't correspond to schema structurally

71+* json source is malformed or doesn't correspond to a schema structurally

72−* some of the runtime validations failed, but it's structurally correct

72+* some of the runtime validations have failed, but it's structurally correct

73+ overall

74−I t's build a transport layer representation of that data that can be tranversed and transformed to whatever internal types user has. Transport layer represetation looks like this. Type parameter is the schema itself.

75+It implies a transport layer representation of that data that can be traversed and transformed to whatever internal types user has. It's called `JsonRepr`. Type parameter is the schema itself.

77```

78```

@@ -84,9 +85,9 @@ jsonExample = ReprObject $

85## Migrations

86## Migrations

87−It's possible to represent schema changes as a migration, which describes a series of json-path/change pairs. Migrations can be applied in succession.

88+It's possible to represent schema changes as a series of migrations, which describes a series of json-path/change pairs. Migrations can be applied in succession.

89−This piece of code will apply a migration to the schema, then decodes and validates the latest version.

90+This piece of code will apply a migration to the schema, decode and validate the latest version.

91```

92```

92type SchemaExample

93type SchemaExample

schematic.cabal+2−2

@@ -66,12 +66,12 @@ library

66 , singletons

67 , smallcheck

68 , smallcheck-series

69+ , superrecord

69 , tagged

70 , tagged

70 , text

71 , text

71 , unordered-containers

72 , unordered-containers

72 , validationt >= 0.1.0.1

73 , validationt >= 0.1.0.1

73 , vector

74 , vector

74− , vinyl

75 hs-source-dirs: src

76 default-language: Haskell2010

@@ -120,10 +120,10 @@ test-suite spec

120 , smallcheck

121 , smallcheck-series

122 , singletons

123+ , superrecord

123 , tagged

124 , tagged

124 , text

125 , text

125 , unordered-containers

126 , unordered-containers

126 , validationt >= 0.1.0.1

127 , validationt >= 0.1.0.1

127− , vinyl

128 other-modules: SchemaSpec

129 , LensSpec

src/Data/Schematic/Instances.hs+5−6

@@ -5,16 +5,15 @@ module Data.Schematic.Instances where

6import Data.Scientific

7import Data.Vector as V

8−import Data.Vinyl

9import Test.SmallCheck.Series

8import Test.SmallCheck.Series

12−instance Monad m => Serial m (Rec f '[]) where

11+-- instance Monad m => Serial m (Rec f '[]) where

13− series = cons0 RNil

12+-- series = cons0 RNil

15−instance (Serial m (f a), Serial m (Rec f as), Monad m)

14+-- instance (Serial m (f a), Serial m (Rec f as), Monad m)

16− => Serial m (Rec f (a ': as)) where

15+-- => Serial m (Rec f (a ': as)) where

17− series = cons2 (:&)

16+-- series = cons2 (:&)

19instance Serial m a => Serial m (V.Vector a) where

18instance Serial m a => Serial m (V.Vector a) where

20 series = V.fromList <$> series

19 series = V.fromList <$> series

src/Data/Schematic/Schema.hs+37−26

@@ -5,25 +5,24 @@

6module Data.Schematic.Schema where

8−import Control.Applicative ()

8+import Control.Applicative ()

9−import Control.Monad

9+import Control.Monad

10−import Data.Aeson as J

10+import Data.Aeson as J

11−import Data.Aeson.Types as J

11+import Data.Aeson.Types as J

12−import Data.HashMap.Strict as H

12+import Data.HashMap.Strict as H

13−import Data.Kind

13+import Data.Kind

14−import Data.Maybe

14+import Data.Maybe

15−import Data.Schematic.Instances ()

15+import Data.Schematic.Instances ()

16−import Data.Scientific

16+import Data.Scientific

17−import Data.Singletons.Prelude.List hiding (All)

17+import Data.Singletons.Prelude.List hiding (All)

18−import Data.Singletons.TH

18+import Data.Singletons.TH

19−import Data.Singletons.TypeLits

19+import Data.Singletons.TypeLits

20−import Data.Text as T

20+import Data.Text as T

21−import Data.Vector as V

21+import Data.Vector as V

22−import Data.Vinyl hiding (Dict)

23−import qualified Data.Vinyl.TypeLevel as V

24−import GHC.Generics (Generic)

22+import GHC.Generics (Generic)

25−import Prelude as P

23+import Prelude as P

24+import SuperRecord

26−import Test.SmallCheck.Series

25+import Test.SmallCheck.Series

29type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where

28type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where

@@ -166,12 +165,18 @@ instance

166 => Serial m (FieldRepr '(name, schema)) where

165 => Serial m (FieldRepr '(name, schema)) where

167 series = FieldRepr <$> series

166 series = FieldRepr <$> series

168

167

168+type family Fields (ts :: [u]) :: [] where

169+ Fields '[] = '[]

170+ Fields (t ': ts) = (FieldRepr t ': Fields ts)

171+

172+type JObject ts = Rec (Fields ts)

173+

169data JsonRepr :: Schema -> Type where

174data JsonRepr :: Schema -> Type where

170 ReprText :: Text -> JsonRepr ('SchemaText cs)

175 ReprText :: Text -> JsonRepr ('SchemaText cs)

171 ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)

176 ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)

172 ReprNull :: JsonRepr 'SchemaNull

177 ReprNull :: JsonRepr 'SchemaNull

173 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)

178 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)

174− ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)

179+ ReprObject :: JObject fs -> JsonRepr ('SchemaObject fs)

175 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)

180 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)

176

181

177instance Show (JsonRepr ('SchemaText cs)) where

182instance Show (JsonRepr ('SchemaText cs)) where

@@ -185,7 +190,12 @@ instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"

185instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where

190instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where

186 show (ReprArray v) = "ReprArray " P.++ show v

191 show (ReprArray v) = "ReprArray " P.++ show v

187

192

193+-- There's a PR in the superrecord library, remove it if gets merged.

194+type family RecAll (c :: u -> Constraint) (rs :: [u]) :: Constraint where

195+ RecAll c '[] = ()

196+ RecAll c (r ': rs) = (c r, RecAll c rs)

197+

188−instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where

198+instance RecAll Show fs => Show (JsonRepr ('SchemaObject fs)) where

189 show (ReprObject fs) = "ReprObject " P.++ show fs

199 show (ReprObject fs) = "ReprObject " P.++ show fs

190

200

191instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where

201instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where

@@ -210,11 +220,11 @@ instance (Serial m (JsonRepr s))

210 => Serial m (JsonRepr ('SchemaOptional s)) where

220 => Serial m (JsonRepr ('SchemaOptional s)) where

211 series = cons1 ReprOptional

221 series = cons1 ReprOptional

212

222

213−instance (Monad m, Serial m (Rec FieldRepr fs))

223+instance (Monad m, Serial m (JObject fs))

214 => Serial m (JsonRepr ('SchemaObject fs)) where

224 => Serial m (JsonRepr ('SchemaObject fs)) where

215 series = cons1 ReprObject

225 series = cons1 ReprObject

216

226

217−instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where

227+instance Eq (JObject fs) => Eq (JsonRepr ('SchemaObject fs)) where

218 ReprObject a == ReprObject b = a == b

228 ReprObject a == ReprObject b = a == b

219

229

220instance Eq (JsonRepr ('SchemaText cs)) where

230instance Eq (JsonRepr ('SchemaText cs)) where

@@ -251,7 +261,7 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where

251 $ withArray "Array" (fmap ReprArray . traverse parseJSON) value

261 $ withArray "Array" (fmap ReprArray . traverse parseJSON) value

252 SSchemaObject fs -> do

262 SSchemaObject fs -> do

253 let

263 let

254− demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)

264+ demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (JObject s)

255 demoteFields SNil _ = pure RNil

265 demoteFields SNil _ = pure RNil

256 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do

266 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do

257 let fieldName = T.pack $ symbolVal (Proxy @fn)

267 let fieldName = T.pack $ symbolVal (Proxy @fn)

@@ -287,11 +297,12 @@ instance J.ToJSON (JsonRepr a) where

287 toJSON (ReprArray v) = J.Array $ toJSON <$> v

297 toJSON (ReprArray v) = J.Array $ toJSON <$> v

288 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r

298 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r

289 where

299 where

300+ extract

290− extract :: forall name s . (KnownSymbol name)

301+ :: forall name s . (KnownSymbol name)

291 => FieldRepr '(name, s)

302 => FieldRepr '(name, s)

292 -> (Text, Value)

303 -> (Text, Value)

293 extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s)

304 extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s)

294− fold :: Rec FieldRepr fs -> [(Text, J.Value)]

305+ fold :: JObject fs -> [(Text, J.Value)]

295 fold = \case

306 fold = \case

296 RNil -> []

307 RNil -> []

297 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl

308 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl