3e35d22 · schematic · git.iko.soy

git.iko.soy/schematic

on master help sign in

monadic migrations, remove migratable, 0.2.0.0 bump

3e35d22Denis Redozubov9 years ago

ChangeLog.md+3

compare with master

unifiedsplit

@@ -1,5 +1,8 @@

1# Revision history for schematic

3+## 0.2.0.0 -- 2017-09-26

5+Migratable is deprecated, migrations are now possible in an arbitrary monad.

4## 0.1.5.0 -- 2017-08-22

7## 0.1.5.0 -- 2017-08-22

schematic.cabal+2−1

@@ -2,7 +2,7 @@

2-- documentation, see http://haskell.org/cabal/users-guide/

4name: schematic

5−version: 0.1.6.0

5+version: 0.2.0.0

6synopsis: JSON-biased spec and validation tool

7-- description:

8license: BSD3

@@ -32,6 +32,7 @@ library

32 , DefaultSignatures

33 , DeriveFunctor

34 , DeriveFoldable

35+ , DeriveTraversable

35 , DeriveGeneric

36 , DeriveGeneric

36 , DeriveDataTypeable

37 , DeriveDataTypeable

37 , FlexibleContexts

38 , FlexibleContexts

src/Data/Schematic.hs+18−51

@@ -10,16 +10,13 @@ module Data.Schematic

10 , decodeAndValidateJson

11 , parseAndValidateJson

12 , parseAndValidateJsonBy

13− , parseAndValidateVersionedJson

14 , parseAndValidateTopVersionJson

13 , parseAndValidateTopVersionJson

15− , decodeAndValidateVersionedJson

16 , parseAndValidateWithMList

14 , parseAndValidateWithMList

17 , decodeAndValidateVersionedWithMList

15 , decodeAndValidateVersionedWithMList

18 , isValid

16 , isValid

19 , isDecodingError

17 , isDecodingError

20 , isValidationError

18 , isValidationError

21 , ParseResult(..)

19 , ParseResult(..)

22− , Migratable

23 ) where

20 ) where

25import Control.Monad.Validation

22import Control.Monad.Validation

@@ -78,44 +75,22 @@ parseAndValidateTopVersionJson _ v =

78 Left em -> ValidationError em

75 Left em -> ValidationError em

79 Right () -> Valid jsonRepr

76 Right () -> Valid jsonRepr

81−class Migratable (revisions :: [(Revision, Schema)]) where

82− mparse

83− :: Sing revisions

84− -> J.Value

85− -> ParseResult (JsonRepr (Snd (Head revisions)))

86−

87−instance

88− {-# OVERLAPPING #-}

89− ( TopLevel (Snd rev), SingI (Snd rev) )

90− => Migratable '[rev] where

91− mparse _ = parseAndValidateJson

92−

93−instance {-# OVERLAPPABLE #-}

94− ( Migratable (Tail revisions)

95− , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions))

96− , SingI (Snd (Head revisions)))

97− => Migratable revisions where

98− mparse s v = case parseEither parseJSON v of

99− Left _ ->

100− migrate <$> (mparse (sTail s) v :: ParseResult (JsonRepr (Snd (Head (Tail revisions)))))

101− Right x -> Valid x

102−

103−parseAndValidateVersionedJson

104− :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v))

105− => proxy v

106− -> J.Value

107− -> ParseResult (JsonRepr (Snd (Head (AllVersions v))))

108−parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v

109−

110parseAndValidateWithMList

78parseAndValidateWithMList

79+ :: Monad m

111− :: MList revisions

80+ => MList m revisions

112 -> J.Value

81 -> J.Value

113− -> ParseResult (JsonRepr (Head revisions))

82+ -> m (ParseResult (JsonRepr (Head revisions)))

114−parseAndValidateWithMList MNil v = parseAndValidateJson v

83+parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v

115parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of

84parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of

116− Valid a -> Valid a

85+ Valid a -> pure $ Valid a

86+ DecodingError _ -> do

117− DecodingError _ -> f <$> parseAndValidateWithMList tl v

87+ pr <- parseAndValidateWithMList tl v

88+ let pr' = f <$> pr

89+ sequence pr'

90+ ValidationError _ -> do

118− ValidationError _ -> f <$> parseAndValidateWithMList tl v

91+ pr <- parseAndValidateWithMList tl v

92+ let pr' = f <$> pr

93+ sequence pr'

119

120decodeAndValidateJson

95decodeAndValidateJson

121 :: forall schema

96 :: forall schema

@@ -126,24 +101,16 @@ decodeAndValidateJson bs = case decode bs of

126 Nothing -> DecodingError "malformed json"

101 Nothing -> DecodingError "malformed json"

127 Just x -> parseAndValidateJson x

102 Just x -> parseAndValidateJson x

128

103

129−decodeAndValidateVersionedJson

130− :: (Migratable (AllVersions versioned), SingI (AllVersions versioned))

131− => proxy versioned

132− -> BL.ByteString

133− -> ParseResult (JsonRepr (Snd (Head (AllVersions versioned))))

134−decodeAndValidateVersionedJson vp bs = case decode bs of

135− Nothing -> DecodingError "malformed json"

136− Just x -> parseAndValidateVersionedJson vp x

137−

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

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

139 MapSnd '[] = '[]

105 MapSnd '[] = '[]

140 MapSnd ( '(a, b) ': tl) = b ': MapSnd tl

106 MapSnd ( '(a, b) ': tl) = b ': MapSnd tl

141

107

142decodeAndValidateVersionedWithMList

108decodeAndValidateVersionedWithMList

109+ :: Monad m

143− :: proxy versioned

110+ => proxy versioned

144− -> MList (MapSnd (AllVersions versioned))

111+ -> MList m (MapSnd (AllVersions versioned))

145 -> BL.ByteString

112 -> BL.ByteString

146− -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))

113+ -> m (ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned)))))

147decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of

114decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of

148− Nothing -> DecodingError "malformed json"

115+ Nothing -> pure $ DecodingError "malformed json"

149 Just x -> parseAndValidateWithMList mlist x

116 Just x -> parseAndValidateWithMList mlist x

src/Data/Schematic/Migration.hs+5−8

@@ -99,9 +99,6 @@ type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration]) = (r

99type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where

100 TopVersion ( '(rh, sh) ': tl) = sh

101

102−class MigrateSchema (a :: Schema) (b :: Schema) where

103− migrate :: JsonRepr a -> JsonRepr b

104−

105data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol

102data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol

106

103

107data instance Sing (a :: Action) where

104data instance Sing (a :: Action) where

@@ -141,13 +138,13 @@ data instance Sing (v :: Versioned) where

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

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

142 -> Sing ('Versioned s ms)

139 -> Sing ('Versioned s ms)

143

140

144−data MList :: [Schema] -> Type where

141+data MList :: (* -> *) -> [Schema] -> Type where

145− MNil :: (SingI s, TopLevel s) => MList '[s]

142+ MNil :: (Monad m, SingI s, TopLevel s) => MList m '[s]

146 (:&&)

143 (:&&)

147 :: (TopLevel s, SingI s)

144 :: (TopLevel s, SingI s)

148 => proxy s

145 => proxy s

149− -> (JsonRepr h -> JsonRepr s)

146+ -> (JsonRepr h -> m (JsonRepr s))

150− -> MList (h ': tl)

147+ -> MList m (h ': tl)

151− -> MList (s ': h ': tl)

148+ -> MList m (s ': h ': tl)

152

149

153infixr 7 :&&

150infixr 7 :&&

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

@@ -12,6 +12,7 @@ import Data.Scientific

12import Data.Singletons.Prelude

13import Data.Singletons.TypeLits

14import Data.Text as T

15+import Data.Traversable

15import Data.Vector as V

16import Data.Vector as V

16import Data.Vinyl

17import Data.Vinyl

17import Prelude as P

18import Prelude as P

@@ -26,7 +27,7 @@ data ParseResult a

26 = Valid a

27 = Valid a

27 | DecodingError Text -- static

28 | DecodingError Text -- static

28 | ValidationError ErrorMap -- runtime

29 | ValidationError ErrorMap -- runtime

29− deriving (Show, Eq, Functor)

30+ deriving (Show, Eq, Functor, Foldable, Traversable)

31isValid :: ParseResult a -> Bool

32isValid :: ParseResult a -> Bool

32isValid (Valid _) = True

33isValid (Valid _) = True