ce63ac6 · typeable/schematic

git.iko.soy/typeable/schematic

Migration fixes

commitce63ac61bcce686cd911a2c74ef79a32a73fa62d authorDenis Redozubov <denis.redozubov@gmail.com> dateSat 10 Jun 2017, 16:22 (9 years ago) parent82c89f2

4 files changed+81−45

compare with master

unifiedsplit

src/Data/Schematic.hs+41−4 src/Data/Schematic/Migration.hs+23−38 src/Data/Schematic/Validation.hs+2−2 test/SchemaSpec.hs+15−1

src/Data/Schematic.hs+41−4

@@ -3,11 +3,13 @@

44module Data.Schematic

55 ( module Data.Schematic.Schema

6+ , module Data.Schematic.Migration

67 , module Data.Schematic.Utils

78 , decodeAndValidateJson

89 , parseAndValidateJson

910 , parseAndValidateVersionedJson

1011 , parseAndValidateTopVersionJson

12+ , decodeAndValidateVersionedJson

1113 , isValid

1214 , isDecodingError

1315 , isValidationError

@@ -68,7 +70,10 @@ class Migratable (revisions :: [(Revision, Schema)]) where

6870 -> J.Value

6971 -> ParseResult (JsonRepr (Snd (Head revisions)))

7072

71−instance {-# OVERLAPPING #-}

73+instance {-# OVERLAPPING #-} (TopLevel (Snd rev), SingI (Snd rev)) => Migratable '[rev] where

74+ mparse _ = parseAndValidateJson

75+

76+instance {-# OVERLAPPABLE #-}

7277 ( Migratable (Tail revisions)

7378 , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))

7479 , SingI (Snd (Head revisions)))

@@ -76,9 +81,32 @@ instance {-# OVERLAPPING #-}

7681 mparse s v = case parseEither parseJSON v of

7782 Left _ -> migrate <$> mparse (sTail s) v

7883 Right x -> Valid x

84+-- type family Migratable (revisions :: [(Revision, Schema)]) = (cs :: Constraint) where

85+-- Migratable '[rev] = (TopLevel (Snd rev), SingI (Snd rev))

86+-- Migratable revisions =

87+-- ( Migratable (Tail revisions)

88+-- , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))

89+-- , SingI (Snd (Head revisions)))

7990

80−instance {-# OVERLAPPABLE #-} (TopLevel (Snd rev), SingI (Snd rev)) => Migratable '[rev] where

81− mparse _ = parseAndValidateJson

91+-- mparseBySing

92+-- :: Sing schema

93+-- -> J.Value

94+-- -> ParseResult (JsonRepr (Snd (Head revisions)))

95+-- mparseBySing s v = undefined

96+

97+-- mparse

98+-- :: Migratable revisions

99+-- => Sing revisions

100+-- -> J.Value

101+-- -> ParseResult (JsonRepr (Snd (Head revisions)))

102+-- mparse s v =

103+-- let

104+-- st = sTail s

105+-- sth = sSnd $ sHead st

106+-- SCons x SNil -> parseAndValidateJson v

107+-- SCons sch _ -> case parseEither parseJSON v of

108+-- Left _ -> migrate <$> mparse (sTail s) v

109+-- Right x -> Valid x

82110

83111parseAndValidateVersionedJson

84112 :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v))

@@ -93,5 +121,14 @@ decodeAndValidateJson

93121 => BL.ByteString

94122 -> ParseResult (JsonRepr schema)

95123decodeAndValidateJson bs = case decode bs of

96− Nothing -> DecodingError "invalid json"

124+ Nothing -> DecodingError "malformed json"

97125 Just x -> parseAndValidateJson x

126+

127+decodeAndValidateVersionedJson

128+ :: (Migratable (AllVersions versioned), SingI (AllVersions versioned))

129+ => proxy versioned

130+ -> BL.ByteString

131+ -> ParseResult (JsonRepr (Snd (Head (AllVersions versioned))))

132+decodeAndValidateVersionedJson vp bs = case decode bs of

133+ Nothing -> DecodingError "malformed json"

134+ Just x -> parseAndValidateVersionedJson vp x

src/Data/Schematic/Migration.hs+23−38

@@ -8,7 +8,7 @@ import Data.Schematic.Path

88import Data.Schematic.Schema

99import Data.Singletons.Prelude hiding (All)

1010import Data.Singletons.TypeLits

11−import Data.Vinyl hiding (Dict)

11+-- import Data.Vinyl hiding (Dict)

1212

1313

1414data Path

@@ -41,14 +41,17 @@ type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol

4141 DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl

4242 DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)

4343

44−type family UpdateKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) (s :: Schema) :: [(Symbol, Schema)] where

45− UpdateKey acc fn ( '(fn, n) ': tl ) s = '(fn, s) ': tl

46− UpdateKey acc fn ( '(a, n) ': tl) s = UpdateKey (acc :++ '[ '(a,n) ]) fn tl s

44+type family UpdateKey

45+ (fn :: Symbol)

46+ (fs :: [(Symbol, Schema)])

47+ (s :: Schema) = (r :: [(Symbol, Schema)]) where

48+ UpdateKey fn ( '(fn, a) ': tl ) s = ( '(fn, s) ': tl )

49+ UpdateKey fn ( '(fs, a) ': tl ) s = ( '(fs, a) ': UpdateKey fn tl s)

4750

4851-- schema updates

4952

5053type family Build (b :: Builder) :: Schema where

51− Build ('BKey ('SchemaObject fs) fn z) = 'SchemaObject (UpdateKey '[] fn fs (Build z))

54+ Build ('BKey ('SchemaObject fs) fn z) = 'SchemaObject (UpdateKey fn fs (Build z))

5255 Build ('BTraverse ('SchemaArray acs s) z) = 'SchemaArray acs (Build z)

5356 Build ('BScalar s) = s

5457

@@ -77,10 +80,6 @@ type family SchemaByRevision (r :: Revision) (vd :: Versioned) :: Schema where

7780 SchemaByRevision r ('Versioned s (m ': ms)) =

7881 SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)

7982

80−-- type family Reverse (acc :: [(Revision, Schema)]) (rs :: [(Revision, Schema)]) :: [(Revision, Schema)] where

81−-- Reverse acc '[] = acc

82−-- Reverse acc (h ': tl) = Reverse (h ': acc) tl

83−

8483type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where

8584 ElemOf e '[] = 'True ~ 'False

8685 ElemOf e ( '(a, e) ': es) = ()

@@ -147,32 +146,18 @@ data instance Sing (v :: Versioned) where

147146 -> Sing (ms :: [Migration]) -- a bunch of migrations

148147 -> Sing ('Versioned s ms)

149148

150−-- data MList ms where

151−-- MSing :: proxy a -> MList '[a]

152−-- MCons :: Dict (MigrateSchema h a) -> proxy a -> MList (h ': tl) -> MList (a ': h ': tl)

153−

154−-- data MList ms where

155−-- MSing :: proxy a -> MList '[a]

156−-- MCons :: (JsonRepr h -> JsonRepr a) -> proxy a -> MList (h ': tl) -> MList (a ': h ': tl)

157−

158−type SchemaExample

159− = 'SchemaObject

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

161− , '("bar", 'SchemaOptional ( 'SchemaText '[ 'TRegex "\\w+", 'TEnum '["foo", "bar"]]))]

162−

163−type VS =

164− 'Versioned SchemaExample

165− '[ 'Migration "test_revision"

166− '[ 'Diff '[ 'PKey "foo" ] ('Update ('SchemaText '[])) ] ]

167−

168−jsonExample :: JsonRepr (TopVersion (AllVersions VS))

169−jsonExample = ReprObject $

170− FieldRepr (ReprText "foo")

171− :& FieldRepr (ReprOptional (Just (ReprText "bar")))

172− :& RNil

173−

174−

175−-- tail :: [a] -> [a]

176−-- sTail :: Sing s -> Sing (Tail s)

177−-- :: (Head (Tail foo))

178−-- sHead (sTail foo)

149+-- type SchemaExample

150+-- = 'SchemaObject

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

152+-- , '("bar", 'SchemaOptional ( 'SchemaText '[ 'TRegex "\\w+", 'TEnum '["foo", "bar"]]))]

153+

154+-- type VS =

155+-- 'Versioned SchemaExample

156+-- '[ 'Migration "test_revision"

157+-- '[ 'Diff '[ 'PKey "foo" ] ('Update ('SchemaText '[])) ] ]

158+

159+-- jsonExample :: JsonRepr (TopVersion (AllVersions VS))

160+-- jsonExample = ReprObject $

161+-- FieldRepr (ReprText "foo")

162+-- :& FieldRepr (ReprOptional (Just (ReprText "bar")))

163+-- :& RNil

src/Data/Schematic/Validation.hs+2−2

@@ -24,8 +24,8 @@ type ErrorMap = MonoidMap Text [Text]

2424

2525data ParseResult a

2626 = Valid a

27− | DecodingError Text

28− | ValidationError ErrorMap

27+ | DecodingError Text -- static

28+ | ValidationError ErrorMap -- runtime

2929 deriving (Show, Eq, Functor)

3030

3131isValid :: ParseResult a -> Bool

test/SchemaSpec.hs+15−1

@@ -1,3 +1,5 @@

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

13module SchemaSpec (spec, main) where

35import Control.Monad

@@ -16,7 +18,13 @@ import Test.SmallCheck.Series.Instances

1618type SchemaExample

1719 = SchemaObject

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

19− , '("bar", SchemaOptional (SchemaText '[TRegex "\\w+", TEnum '["foo", "bar"]]))]

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

22+

23+type VS =

24+ 'Versioned SchemaExample

25+ '[ 'Migration "test_revision"

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

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

2028

2129exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3]))

2230exampleTest = ReprOptional (Just (ReprText "lil"))

@@ -39,6 +47,9 @@ schemaJson = "{\"foo\": [13], \"bar\": null}"

3947schemaJson2 :: ByteString

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

4149

50+schemaJsonTopVersion :: ByteString

51+schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }"

52+

4253spec :: Spec

4354spec = do

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

@@ -54,6 +65,9 @@ spec = do

5465 it "validates incorrect representation" $

5566 ((decodeAndValidateJson schemaJson2) :: ParseResult (JsonRepr SchemaExample))

5667 `shouldSatisfy` isValidationError

68+ it "validates versioned json" $ do

69+ (decodeAndValidateVersionedJson (Proxy @VS) schemaJsonTopVersion)

70+ `shouldSatisfy` isValid

5771

5872main :: IO ()

5973main = hspec spec