ce63ac6 · typeable/schematic

git.iko.soy/typeable/schematic

on master help sign in

Migration fixes

ce63ac6Denis Redozubov9 years ago

src/Data/Schematic.hs+41−4

compare with master

unifiedsplit

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

4module Data.Schematic

5 ( module Data.Schematic.Schema

6+ , module Data.Schematic.Migration

6 , module Data.Schematic.Utils

7 , module Data.Schematic.Utils

7 , decodeAndValidateJson

8 , decodeAndValidateJson

8 , parseAndValidateJson

9 , parseAndValidateJson

9 , parseAndValidateVersionedJson

10 , parseAndValidateVersionedJson

10 , parseAndValidateTopVersionJson

11 , parseAndValidateTopVersionJson

12+ , decodeAndValidateVersionedJson

11 , isValid

13 , isValid

12 , isDecodingError

14 , isDecodingError

13 , isValidationError

15 , isValidationError

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

68 -> J.Value

70 -> J.Value

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

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

71−instance {-# OVERLAPPING #-}

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

74+ mparse _ = parseAndValidateJson

75+

76+instance {-# OVERLAPPABLE #-}

72 ( Migratable (Tail revisions)

77 ( Migratable (Tail revisions)

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

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

74 , SingI (Snd (Head revisions)))

79 , SingI (Snd (Head revisions)))

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

76 mparse s v = case parseEither parseJSON v of

81 mparse s v = case parseEither parseJSON v of

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

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

78 Right x -> Valid x

83 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)))

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

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

81− mparse _ = parseAndValidateJson

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

110

83parseAndValidateVersionedJson

111parseAndValidateVersionedJson

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

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

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

93 => BL.ByteString

121 => BL.ByteString

94 -> ParseResult (JsonRepr schema)

122 -> ParseResult (JsonRepr schema)

95decodeAndValidateJson bs = case decode bs of

123decodeAndValidateJson bs = case decode bs of

96− Nothing -> DecodingError "invalid json"

124+ Nothing -> DecodingError "malformed json"

97 Just x -> parseAndValidateJson x

125 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

8import Data.Schematic.Schema

9import Data.Singletons.Prelude hiding (All)

10import Data.Singletons.TypeLits

11−import Data.Vinyl hiding (Dict)

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

14data Path

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

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

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

44+type family UpdateKey

45+ (fn :: Symbol)

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

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

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

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

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

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

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

48-- schema updates

51-- schema updates

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

53type 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))

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

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

53 Build ('BScalar s) = s

56 Build ('BScalar s) = s

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

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

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

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

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

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−

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

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

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

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

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

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

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

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

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

148 -> Sing ('Versioned s ms)

147 -> Sing ('Versioned s ms)

149

148

150−-- data MList ms where

149+-- type SchemaExample

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

150+-- = 'SchemaObject

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

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

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

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

162−

153+

163−type VS =

154+-- type VS =

164− 'Versioned SchemaExample

155+-- 'Versioned SchemaExample

165− '[ 'Migration "test_revision"

156+-- '[ 'Migration "test_revision"

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

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

167−

158+

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

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

169−jsonExample = ReprObject $

160+-- jsonExample = ReprObject $

170− FieldRepr (ReprText "foo")

161+-- FieldRepr (ReprText "foo")

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

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

172− :& RNil

163+-- :& RNil

173−

174−

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

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

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

178−-- sHead (sTail foo)

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

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

25data ParseResult a

26 = Valid a

27− | DecodingError Text

27+ | DecodingError Text -- static

28− | ValidationError ErrorMap

28+ | ValidationError ErrorMap -- runtime

29 deriving (Show, Eq, Functor)

31isValid :: ParseResult a -> Bool

test/SchemaSpec.hs+15−1

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

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

1module SchemaSpec (spec, main) where

3module SchemaSpec (spec, main) where

3import Control.Monad

5import Control.Monad

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

16type SchemaExample

18type SchemaExample

17 = SchemaObject

19 = SchemaObject

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

20 '[ '("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 '[])) ] ]

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

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

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

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

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

39schemaJson2 :: ByteString

47schemaJson2 :: ByteString

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

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

50+schemaJsonTopVersion :: ByteString

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

52+

42spec :: Spec

53spec :: Spec

43spec = do

54spec = do

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

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

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

54 it "validates incorrect representation" $

65 it "validates incorrect representation" $

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

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

56 `shouldSatisfy` isValidationError

67 `shouldSatisfy` isValidationError

68+ it "validates versioned json" $ do

69+ (decodeAndValidateVersionedJson (Proxy @VS) schemaJsonTopVersion)

70+ `shouldSatisfy` isValid

58main :: IO ()

72main :: IO ()

59main = hspec spec

73main = hspec spec