85c3137 · schematic · git.iko.soy

git.iko.soy/schematic

on master help sign in

Add migrateObject and shrinkObjects, updated README

85c3137Denis Redozubov9 years ago

README.md+146−21

compare with master

unifiedsplit

@@ -22,9 +22,35 @@ Be aware that library is experimental and subject to change a lot. The current s

22$ stack install schematic

23```

25−## Basic Examples

25+## GHC Extensions

26+

27+To use this library without any hassle, you should add a few GHC extension

28+either to a module or a cabal file:

27```

30```

31+DataKinds

32+OverloadedLists

33+OverloadedStrings

34+TypeApplications

35+```

36+

37+`Overloaded`-extensions are being used only by `field` combinator,

38+so it you don't use it - feel free to disable it.

39+

40+## GHC Options

41+

42+I recommend using `{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}`

43+pragma in modules which declare schemas and schema migrations, because `schematic`

44+heavily uses promoted types which should be prefixed with "`" signs and they can

45+be dropped with this option, making it less noisy visually.

46+It's entirely optional and totally opinionated, so feel free to ignore this.

47+Through the documentation, the code is written without any explicit ticks for

48+the same reason.

49+Notice that they're still needed for type-level lists and tuples in schematic code.

50+

51+## Basic Examples

52+

53+```haskell

28type SchemaExample

54type SchemaExample

29 = SchemaObject

55 = SchemaObject

30 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))

56 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))

@@ -42,21 +68,21 @@ type SchemaExample

43This one is valid for example

69This one is valid for example

45−```

71+```haskell

46schemaJson :: ByteString

72schemaJson :: ByteString

47schemaJson = "{\"foo\": [13], \"bar\": null}"

73schemaJson = "{\"foo\": [13], \"bar\": null}"

48```

74```

50Also valid

76Also valid

52−```

78+```haskell

53schemaJson :: ByteString

79schemaJson :: ByteString

54schemaJson = "{\"foo\": [13], \"bar\": \"bar\"}"

80schemaJson = "{\"foo\": [13], \"bar\": \"bar\"}"

55```

81```

57it can be parsed and validated like this:

83it can be parsed and validated like this:

59−```

85+```haskell

60decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)

86decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)

61```

87```

@@ -66,24 +92,64 @@ decodeAndValidateJson schemaJson :: ParseResult (JsonRepr SchemaExample)

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

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

67 overall

93 overall

69−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.

95+It implies a transport layer representation of that data that can be traversed

96+and transformed to whatever internal types user has.

97+It's called `JsonRepr`. Type parameter is the schema itself.

98+

99+```haskell

100+jsonExample :: JsonRepr SchemaExample

101+jsonExample = withRepr @SchemaExample

102+ $ field @"foo" [12]

103+ :& field @"bar" (Just "bar")

104+ :& RNil

105+```

106

107+The most basic and sugar-free way of constructing the same object will look like this:

108

72```

109```

73−jsonExample :: JsonRepr SchemaExample

110+jsonExample' :: JsonRepr SchemaExample

74−jsonExample = ReprObject $

111+jsonExample' = ReprObject $

75 FieldRepr (ReprArray [ReprNumber 12])

112 FieldRepr (ReprArray [ReprNumber 12])

76 :& FieldRepr (ReprOptional (Just (ReprText "bar")))

113 :& FieldRepr (ReprOptional (Just (ReprText "bar")))

77 :& RNil

114 :& RNil

78```

115```

116

117+## Lens-compatibility

118+

119+It's possible to use `flens` to construct a field lens for a typed object in schematic. Let's suppose you have a schema like this:

120+

121+```haskell

122+type ArraySchema = SchemaArray '[AEq 1] (SchemaNumber '[NGt 10])

123+

124+type ArrayField = '("foo", ArraySchema)

125+

126+type FieldsSchema =

127+ '[ ArrayField, '("bar", SchemaOptional (SchemaText '[TEnum '["foo", "bar"]]))]

128+

129+type SchemaExample = 'SchemaObject FieldsSchema

130+

131+```

132+

133+There are two ways of working with named fields in the objects:

134+

135+* Using the `fget` and `fset` functions: `fget fooProxy (fput newFooVal objectData) == newFooVal`

136+* Using the lens library: `set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo") == newFooVal`

137+

80## Migrations

138## Migrations

139

140+Usually migrations are implicit and hard to deal with, `schematic` deals with it

141+by giving tools to deal with it to a programmer, being as explicit as possible,

142+notifying the developer of a missing transition with a compile-time error.

143+It allows to build versioned HTTP APIs or migrate data from the older versions

144+when reading from the JSON storages.

145+

146+It's possible to represent schema changes as a series of migrations,

82−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.

147+which describes a series of json-path/change pairs. Migrations can be applied in

148+succession.

149

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

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

151

86−```

152+```haskell

87type SchemaExample

153type SchemaExample

88 = SchemaObject

154 = SchemaObject

89 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))

155 '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))

@@ -91,8 +157,8 @@ type SchemaExample

157

92type TestMigration =

158type TestMigration =

93 'Migration "test_revision"

159 'Migration "test_revision"

94− '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))

160+ '[ Diff '[ PKey "bar" ] (Update (SchemaText '[]))

95− , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]

161+ , Diff '[ PKey "foo" ] (Update (SchemaNumber '[])) ]

162

97type VS = 'Versioned SchemaExample '[ TestMigration ]

163type VS = 'Versioned SchemaExample '[ TestMigration ]

164

@@ -106,25 +172,84 @@ It's possible to decode the latest version like this:

106decodeAndValidateJson schemaJsonTopVersion :: ParseResult (JsonRepr (TopVersion (AllVersions VS)))

172decodeAndValidateJson schemaJsonTopVersion :: ParseResult (JsonRepr (TopVersion (AllVersions VS)))

107```

173```

108

174

109−## Lens-compatibility

175+It's important to differentiate between schema migrations and data migrations.

176+Schema migration is a change of a schema acceptable by a JSON consumer. It transforms one schema to another.

177+Data migrations on the other hand are functions on the data itself. They transform values

178+acceptable by one schema to values acceptable by another.

179+Let's look at the situation when we have to add a field to a JSON Object of a current schema:

110

180

111−It's possible to use `flens` to construct a field lens for a typed object in schematic. Let's suppose you have a schema like this:

181+```

182+type SchemaExample = 'SchemaObject

183+ '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))

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

185+

186+jsonExample :: JsonRepr SchemaExample

187+jsonExample = withRepr @SchemaExample

188+ $ field @"bar" (Just "bar")

189+ :& field @"foo" [12]

190+ :& RNil

191+

192+type AddQuuz =

193+ 'Migration "add_field_quuz"

194+ '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ]

195+

196+type DeleteQuuz =

197+ 'Migration "remove_field_quuz"

198+ '[ 'Diff '[] ( 'DeleteKey "quuz") ]

199+

200+type Migrations = '[ AddQuuz

201+ , DeleteQuuz ]

202+

203+type VersionedJson = 'Versioned SchemaExample Migrations

204+

205+migrationList :: MigrationList Identity VersionedJson

206+migrationList

207+ = (migrateObject (\r -> Identity $ field @"quuz" 42 :& r))

208+ :&& shrinkObject

209+ :&& MNil

112

210

113```

211```

114−type ArraySchema = 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10])

115

212

116−type ArrayField = '("foo", ArraySchema)

213+In this instance `Migrations` is a list of schema migrations and

214+`MigrationList Identity VersionedJson` is a list of data migrations corresponding

215+to the list of schema migrations: `migrateObject (\r -> Identity $ field @"quuz" 42 :& r))`

216+will be used at runtime to transform `JsonRepr SchemaExample` to

217+`JsonRepr (SchemaByRevision "add_quuz" VersionedJson). `Identity` in the type of

218+`MigrationList` is a monad we choose to run our migrations in. If there's need to

219+do database queries or something like that, it can be changed to something more

220+appropriate by a user.

221+`migrateObject` takes a function transforming old fields into new ones, `shrinkObject`

222+allows to shrink the JSON object in case migration only removed fields.

117

223

118−type FieldsSchema =

224+## How do I construct a value of `JsonRepr schema`?

119− '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]

120

225

121−type SchemaExample = 'SchemaObject FieldsSchema

226+`JsonRepr schema` is a primary representation of a value serializable/deserializable

227+to JSON, but with a twist. It's guaranteed to correspond a type-level schema,

228+it's a type parameter of a same name.

229+It makes constructing it a little bit more involved, but luckily `schematic`

230+provides a DSL for doing so in a more straightforward fashion. An example would

231+look like this:

122

232

233+```haskell

234+type SchemaExample = 'SchemaObject

235+ '[ '("foo", SchemaArray '[ AEq 1] (SchemaNumber '[NGt 10]))

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

237+

238+jsonExample = withRepr @SchemaExample

239+ $ field @"bar" (Just "bar")

240+ :& field @"foo" [12]

241+ :& RNil

123```

242```

124

243

125−There are two ways of working with named fields in the objects:

244+`@foo` syntax is an explicit type application, which is a feature of GHC 8+, it

245+makes type inference possible without relying on a bunch of `Proxy`s, which

246+makes it syntactically more terse.

247+

248+[GHC Type Applications](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication)

249+

250+`schematic` provides instances for `OverloadedLists` and `OverloadedStrings`

251+GHC extensions to make use of string and list literals for values in a previous

252+example.

126

253

127−* Using the `fget` and `fset` functions: `fget fooProxy (fput newFooVal objectData) == newFooVal`

128−* Using the lens library: `set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo") == newFooVal`

129

254

130## Export to json-schema (draft 4)

255## Export to json-schema (draft 4)

schematic.cabal−27

@@ -85,33 +85,6 @@ test-suite spec

85 hs-source-dirs: test

86 main-is: Spec.hs

87 default-language: Haskell2010

88− default-extensions: ConstraintKinds

89− , DataKinds

90− , DeriveFunctor

91− , DeriveFoldable

92− , DeriveGeneric

93− , DeriveDataTypeable

94− , FlexibleContexts

95− , FlexibleInstances

96− , FunctionalDependencies

97− , GADTs

98− , KindSignatures

99− , InstanceSigs

100− , LambdaCase

101− , MultiParamTypeClasses

102− , OverloadedLists

103− , OverloadedStrings

104− , PolyKinds

105− , QuasiQuotes

106− , PartialTypeSignatures

107− , RecordWildCards

108− , ScopedTypeVariables

109− , TemplateHaskell

110− , TypeApplications

111− , TypeFamilies

112− , TypeInType

113− , TypeOperators

114− , TypeSynonymInstances

115 build-depends: HUnit

88 build-depends: HUnit

116 , aeson >= 1

89 , aeson >= 1

117 , base >=4.9 && <4.11

90 , base >=4.9 && <4.11

src/Data/Schematic.hs−4

@@ -107,10 +107,6 @@ decodeAndValidateJson bs = case decode bs of

107 Nothing -> DecodingError "malformed json"

108 Just x -> parseAndValidateJson x

109

110−type family MapSnd (l :: [(a,k)]) = (r :: [k]) where

111− MapSnd '[] = '[]

112− MapSnd ( '(a, b) ': tl) = b ': MapSnd tl

113−

114decodeAndValidateVersionedWithMList

110decodeAndValidateVersionedWithMList

115 :: Monad m

111 :: Monad m

116 => proxy versioned

112 => proxy versioned

src/Data/Schematic/DSL.hs−1

@@ -4,7 +4,6 @@ module Data.Schematic.DSL where

5import Data.Kind

6import Data.Schematic.Lens

7−import Data.Schematic.Migration

8import Data.Schematic.Schema

7import Data.Schematic.Schema

9import Data.Scientific

8import Data.Scientific

10import Data.Singletons

9import Data.Singletons

src/Data/Schematic/Migration.hs+29−2

@@ -4,11 +4,15 @@

4module Data.Schematic.Migration where

6import Data.Kind

7+import Data.Schematic.DSL

8+import Data.Schematic.Lens

7import Data.Schematic.Path

9import Data.Schematic.Path

8import Data.Tagged

10import Data.Tagged

9import Data.Schematic.Schema

11import Data.Schematic.Schema

10−import Data.Singletons.Prelude hiding (All)

12+import Data.Singletons.Prelude hiding (All, (:.))

11import Data.Singletons.TypeLits

13import Data.Singletons.TypeLits

14+import Data.Vinyl

15+import Data.Vinyl.Functor

14data Path

18data Path

@@ -92,7 +96,8 @@ type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where

92type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where

96type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where

93 AllVersions ('Versioned s ms) = Reverse (AllVersions' '[ '("initial", s) ] ms)

97 AllVersions ('Versioned s ms) = Reverse (AllVersions' '[ '("initial", s) ] ms)

95−type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration]) = (r :: [(Revision, Schema)]) where

99+type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration])

100+ = (r :: [(Revision, Schema)]) where

96 AllVersions' acc '[] = acc

101 AllVersions' acc '[] = acc

97 AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =

102 AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =

98 AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms

103 AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms

@@ -150,3 +155,25 @@ data MList :: (* -> *) -> [Schema] -> Type where

150 -> MList m (s ': h ': tl)

155 -> MList m (s ': h ': tl)

151

156

152infixr 7 :&&

157infixr 7 :&&

158+

159+migrateObject

160+ :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m)

161+ => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))

162+ -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))

163+migrateObject f = Tagged $ \(ReprObject r) -> do

164+ res <- f $ rmap (Compose . Tagged) r

165+ pure $ withRepr @('SchemaObject fs) res

166+

167+shrinkObject

168+ :: forall rs ss m

169+ . ( Monad m, FSubset rs ss (FImage rs ss) )

170+ => Tagged

171+ ('SchemaObject rs)

172+ (JsonRepr ('SchemaObject ss) -> m (JsonRepr ('SchemaObject rs)))

173+shrinkObject = Tagged $ \(ReprObject r) -> pure $ ReprObject $ fcast r

174+

175+type family MapSnd (l :: [(a,k)]) = (r :: [k]) where

176+ MapSnd '[] = '[]

177+ MapSnd ( '(a, b) ': tl) = b ': MapSnd tl

178+

179+type MigrationList m vs = MList m (MapSnd (AllVersions vs))

test/HelpersSpec.hs+6

@@ -1,5 +1,11 @@

1{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

3+{-# LANGUAGE LambdaCase #-}

5+{-# LANGUAGE DataKinds #-}

6+{-# LANGUAGE TypeApplications #-}

7+{-# LANGUAGE OverloadedStrings #-}

3module HelpersSpec (spec, main) where

9module HelpersSpec (spec, main) where

5import Control.Lens

11import Control.Lens

test/JsonSchemaSpec.hs+7

@@ -1,3 +1,10 @@

1+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE TypeApplications #-}

5+{-# LANGUAGE OverloadedLists #-}

6+{-# LANGUAGE OverloadedStrings #-}

1module JsonSchemaSpec (spec, main) where

8module JsonSchemaSpec (spec, main) where

3import Data.Aeson as J

10import Data.Aeson as J

test/LensSpec.hs+5

@@ -1,3 +1,8 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeApplications #-}

3+{-# LANGUAGE OverloadedLists #-}

4+{-# LANGUAGE OverloadedStrings #-}

1module LensSpec (spec, main) where

6module LensSpec (spec, main) where

3import Control.Lens

8import Control.Lens

test/SchemaSpec.hs+41−17

@@ -1,7 +1,17 @@

1{-# OPTIONS_GHC -fprint-potential-instances #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE OverloadedLists #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeApplications #-}

11+

3module SchemaSpec (spec, main) where

12module SchemaSpec (spec, main) where

14+import Control.Lens

5import Data.Aeson

15import Data.Aeson

6import Data.ByteString.Lazy

16import Data.ByteString.Lazy

7import Data.Functor.Identity

17import Data.Functor.Identity

@@ -22,12 +32,36 @@ jsonExample = withRepr @SchemaExample

22 :& field @"foo" [12]

32 :& field @"foo" [12]

23 :& RNil

33 :& RNil

25−type TestMigration =

35+type AddQuuz =

26− 'Migration "test_revision"

36+ 'Migration "add_field_quuz"

37+ '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ]

38+

39+type DeleteQuuz =

40+ 'Migration "remove_field_quuz"

41+ '[ 'Diff '[] ( 'DeleteKey "quuz") ]

42+

43+type SwapFields =

44+ 'Migration "swap_fields"

27− '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))

45+ '[ 'Diff '[ 'PKey "bar" ] ('Update

46+ ('SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])))

28− , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]

47+ , 'Diff '[ 'PKey "foo" ] ('Update

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

50+type Migrations = '[ AddQuuz

51+ , DeleteQuuz ]

52+ -- , SwapFields ]

53+

30−type VS = 'Versioned SchemaExample '[ TestMigration ]

54+type VersionedJson = 'Versioned SchemaExample Migrations

55+

56+migrationList :: MigrationList Identity VersionedJson

57+migrationList

58+ = (migrateObject (\r -> Identity $ field @"quuz" 42 :& r))

59+ :&& shrinkObject

60+ -- :&& (migrateObject (\r -> Identity

61+ -- $ field @"foo" (r ^. flens (Proxy @"bar") . _Just . optionalRepr)

62+ -- :& field @"bar" (r ^. flens (Proxy @"foo") . arrayRepr)

63+ -- :& RNil))

64+ :&& MNil

32schemaJson :: ByteString

66schemaJson :: ByteString

33schemaJson = "{\"foo\": [13], \"bar\": null}"

67schemaJson = "{\"foo\": [13], \"bar\": null}"

@@ -35,16 +69,6 @@ schemaJson = "{\"foo\": [13], \"bar\": null}"

35schemaJson2 :: ByteString

69schemaJson2 :: ByteString

36schemaJson2 = "{\"foo\": [3], \"bar\": null}"

70schemaJson2 = "{\"foo\": [3], \"bar\": null}"

38−topObject

39− :: JsonRepr

40− ('SchemaObject

41− '[ '("foo", 'SchemaNumber '[])

42− , '("bar", 'SchemaText '[])])

43−topObject = ReprObject $

44− FieldRepr (ReprNumber 42)

45− :& FieldRepr (ReprText "test")

46− :& RNil

47−

48spec :: Spec

72spec :: Spec

49spec = do

73spec = do

50 -- it "show/read JsonRepr properly" $

74 -- it "show/read JsonRepr properly" $

@@ -65,8 +89,8 @@ spec = do

65 -- `shouldSatisfy` isValid

89 -- `shouldSatisfy` isValid

66 it "validates versioned json with a migration list" $ do

90 it "validates versioned json with a migration list" $ do

67 decodeAndValidateVersionedWithPureMList

91 decodeAndValidateVersionedWithPureMList

68− (Proxy @VS)

92+ (Proxy @VersionedJson)

69− (Tagged (const $ Identity topObject) :&& MNil)

93+ migrationList

70 schemaJson

94 schemaJson

71 `shouldSatisfy` isValid

95 `shouldSatisfy` isValid