49e8aef · typeable/schematic

src/Data/Schematic.hs+17−15

compare with master

unifiedsplit

@@ -22,20 +22,21 @@ module Data.Schematic

22 , field

23 ) where

24

25−import Control.Monad.Validation

25+import Control.Monad.Validation

26−import Data.Aeson as J

26+import Data.Aeson as J

27−import Data.Aeson.Types as J

27+import Data.Aeson.Types as J

28−import Data.ByteString.Lazy as BL

28+import Data.ByteString.Lazy as BL

29−import Data.Functor.Identity as F

29+import Data.Functor.Identity as F

30−import Data.Schematic.DSL

30+import Data.Schematic.DSL

31−import Data.Schematic.Helpers

31+import Data.Schematic.Helpers

32−import Data.Schematic.JsonSchema

32+import Data.Schematic.JsonSchema

33−import Data.Schematic.Lens

33+import Data.Schematic.Lens

34−import Data.Schematic.Migration

34+import Data.Schematic.Migration

35−import Data.Schematic.Schema

35+import Data.Schematic.Schema

36−import Data.Schematic.Validation

36+import Data.Schematic.Validation

37−import Data.Singletons.Prelude hiding ((:.))

37+import Data.Singletons.Prelude hiding ((:.))

38+import Data.Tagged

38−import Data.Text as T

39+import Data.Text as T

39

40

41

41parseAndValidateJson

42parseAndValidateJson

@@ -85,7 +86,8 @@ parseAndValidateWithMList

85 -> J.Value

86 -> J.Value

86 -> m (ParseResult (JsonRepr (Head revisions)))

87 -> m (ParseResult (JsonRepr (Head revisions)))

87parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v

88parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v

89+parseAndValidateWithMList (Tagged f :&& tl) v =

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

90+ case parseAndValidateJsonBy Proxy v of

89 Valid a -> pure $ Valid a

91 Valid a -> pure $ Valid a

90 DecodingError _ -> do

92 DecodingError _ -> do

91 pr <- parseAndValidateWithMList tl v

93 pr <- parseAndValidateWithMList tl v

src/Data/Schematic/DSL.hs−1

@@ -18,7 +18,6 @@ import Data.Vinyl

18import Data.Vinyl.Functor

19

20

21−

22type Constructor a

21type Constructor a

23 = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)

22 = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)

24 => Rec (Tagged (FieldsOf a) :. FieldRepr) b

23 => Rec (Tagged (FieldsOf a) :. FieldRepr) b

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

@@ -4,6 +4,7 @@

4module Data.Schematic.Migration where

5

6import Data.Kind

7+import Data.Tagged

7import Data.Schematic.Path

8import Data.Schematic.Path

8import Data.Schematic.Schema

9import Data.Schematic.Schema

9import Data.Singletons.Prelude hiding (All)

10import Data.Singletons.Prelude hiding (All)

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

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

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

139 -> Sing ('Versioned s ms)

140 -> Sing ('Versioned s ms)

140

141

142+type DataMigration s m h = Tagged s (JsonRepr h -> m (JsonRepr s))

143+

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

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

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

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

143 (:&&)

146 (:&&)

144 :: (TopLevel s, SingI s)

147 :: (TopLevel s, SingI s)

145− => proxy s

148+ => DataMigration s m h

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

147 -> MList m (h ': tl)

149 -> MList m (h ': tl)

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

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

149

151

test/SchemaSpec.hs+2−3

@@ -7,6 +7,7 @@ import Data.ByteString.Lazy

7import Data.Functor.Identity

8import Data.Proxy

9import Data.Schematic

10+import Data.Tagged

10import Data.Vinyl

11import Data.Vinyl

11import Test.Hspec

12import Test.Hspec

12

13

@@ -65,9 +66,7 @@ spec = do

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

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

66 decodeAndValidateVersionedWithPureMList

67 decodeAndValidateVersionedWithPureMList

67 (Proxy @VS)

68 (Proxy @VS)

68− ((:&&)

69− (Proxy @(SchemaByRevision "test_revision" VS))

70− (const $ Identity topObject) MNil)

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

71 schemaJson

70 schemaJson

72 `shouldSatisfy` isValid

71 `shouldSatisfy` isValid

73

72