git.iko.soy/schematic
on master help sign in
Add migration functionality
82c89f2Denis Redozubov
src/Data/Schematic.hs+15−36
compare with master
unifiedsplit
@@ -7,10 +7,12 @@ module Data.Schematic
7 , decodeAndValidateJson
7 , decodeAndValidateJson
8 , parseAndValidateJson
8 , parseAndValidateJson
9 , parseAndValidateVersionedJson
9 , parseAndValidateVersionedJson
10+ , parseAndValidateTopVersionJson
10 , isValid
11 , isValid
11 , isDecodingError
12 , isDecodingError
12 , isValidationError
13 , isValidationError
13 , ParseResult(..)
14 , ParseResult(..)
15+ , Migratable
14 ) where
16 ) where
15
17
16import Control.Monad.Validation
18import Control.Monad.Validation
@@ -42,27 +44,6 @@ parseAndValidateJson v =
42 Left em -> ValidationError em
44 Left em -> ValidationError em
43 Right () -> Valid jsonRepr
45 Right () -> Valid jsonRepr
44
46
45−parseAndValidateJsonBySing
46− :: forall schema proxy
47− . (J.FromJSON (JsonRepr schema), TopLevel schema)
48− => Sing schema
49− -> J.Value
50− -> ParseResult (JsonRepr schema)
51−parseAndValidateJsonBySing sschema v = case parseEither parseJSON v of
52− Left s -> DecodingError $ T.pack s
53− Right jsonRepr ->
54− let
55− validate = validateJsonRepr sschema [] jsonRepr
56− res = runIdentity . runValidationTEither $ validate
57− in case res of
58− Left em -> ValidationError em
59− Right () -> Valid jsonRepr
60−
61−-- parseAndValidateVersionedJson
62−-- :: MList (m ': ms)
63−-- -> J.Value
64−-- -> ParseResult (JsonRepr)
65−
66parseAndValidateTopVersionJson
47parseAndValidateTopVersionJson
67 :: forall proxy (v :: Versioned)
48 :: forall proxy (v :: Versioned)
68 . (SingI (TopVersion (AllVersions v)))
49 . (SingI (TopVersion (AllVersions v)))
@@ -81,32 +62,30 @@ parseAndValidateTopVersionJson _ v =
81 Left em -> ValidationError em
62 Left em -> ValidationError em
82 Right () -> Valid jsonRepr
63 Right () -> Valid jsonRepr
83
64
84−-- [("top version", schemaTopVersion), ("n-1 version", schemaNminusOneVersion), ...]
85−
86−-- type family Migratable (rs :: [(Revision, Schema)]) :: Constraint where
87−-- -- constraint duplication
88−-- Migratable ('(r,s) ': '(r', s') ': tl) =
89−-- (SingI s, MigrateSchema s s', TopLevel s, Migratable ('(r',s') ': tl))
90−-- Migratable ('(r,s) ': '[]) = (TopLevel s, SingI s)
91−-- -- Migratable '[] = ('True ~ 'False)
92−
93class Migratable (revisions :: [(Revision, Schema)]) where
65class Migratable (revisions :: [(Revision, Schema)]) where
66+ mparse
67+ :: Sing revisions
68+ -> J.Value
94− mparse :: Sing revisions -> J.Value -> Either String (JsonRepr (Snd (Head revisions)))
69+ -> ParseResult (JsonRepr (Snd (Head revisions)))
95
70
71+instance {-# OVERLAPPING #-}
72+ ( Migratable (Tail revisions)
96−instance {-# OVERLAPPING #-} (Migratable (Tail revisions), MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions)), SingI (Snd (Head revisions))) => Migratable revisions where
73+ , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))
74+ , SingI (Snd (Head revisions)))
75+ => Migratable revisions where
97 mparse s v = case parseEither parseJSON v of
76 mparse s v = case parseEither parseJSON v of
98 Left _ -> migrate <$> mparse (sTail s) v
77 Left _ -> migrate <$> mparse (sTail s) v
99− Right x -> Right x
78+ Right x -> Valid x
100
79
101instance {-# OVERLAPPABLE #-} (TopLevel (Snd rev), SingI (Snd rev)) => Migratable '[rev] where
80instance {-# OVERLAPPABLE #-} (TopLevel (Snd rev), SingI (Snd rev)) => Migratable '[rev] where
102− mparse _ = parseEither parseJSON
81+ mparse _ = parseAndValidateJson
103
82
104parseAndValidateVersionedJson
83parseAndValidateVersionedJson
105 :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v))
84 :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v))
106 => proxy v
85 => proxy v
107 -> J.Value
86 -> J.Value
108− -> Either String (JsonRepr (Snd (Head (AllVersions v))))
87+ -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))
109−parseAndValidateVersionedJson s v = mparse (sing :: Sing (AllVersions v)) v
88+parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v
110
89
111decodeAndValidateJson
90decodeAndValidateJson
112 :: forall schema
91 :: forall schema