git.iko.soy/typeable/schematic
on master help sign in
migrations proto encoding
07015beDenis Redozubov
schematic.cabal+2
compare with master
unifiedsplit
@@ -63,6 +63,7 @@ library
63 , singletons
63 , singletons
64 , smallcheck
64 , smallcheck
65 , smallcheck-series
65 , smallcheck-series
66+ , tagged
66 , text
67 , text
67 , unordered-containers
68 , unordered-containers
68 , validationt >= 0.1.0.1
69 , validationt >= 0.1.0.1
@@ -115,6 +116,7 @@ test-suite spec
115 , smallcheck
116 , smallcheck
116 , smallcheck-series
117 , smallcheck-series
117 , singletons
118 , singletons
119+ , tagged
118 , text
120 , text
119 , unordered-containers
121 , unordered-containers
120 , validationt >= 0.1.0.1
122 , validationt >= 0.1.0.1
src/Data/Schematic/Migration.hs+30
@@ -10,6 +10,8 @@ import Data.Schematic.Utils
10import Data.Singletons.Prelude hiding (All)
10import Data.Singletons.Prelude hiding (All)
11import Data.Singletons.TypeLits
11import Data.Singletons.TypeLits
12
12
13+class MigrateSchema (a :: Schema) (b :: Schema) where
14+ migrate :: JsonRepr a -> JsonRepr b
13
15
14data Action = AddKey Symbol Schema | Update Schema | DeleteKey
16data Action = AddKey Symbol Schema | Update Schema | DeleteKey
15
17
@@ -42,13 +44,24 @@ type family TypedDiffList (s :: Schema) (ds :: [Diff]) :: Constraint where
42 TypedDiffList s '[] = ()
44 TypedDiffList s '[] = ()
43 TypedDiffList s (d ': tl) = (TypedDiff s d, TypedDiffList s tl)
45 TypedDiffList s (d ': tl) = (TypedDiff s d, TypedDiffList s tl)
44
46
47+type family TypedDiffListSchema (s :: Schema) (ds :: [Diff]) :: Schema where
48+ TypedDiffListSchema s '[] = s
49+ TypedDiffListSchema s (d ': tl) = TypedDiffListSchema (TypedDiffSchema s d) tl
50+
45type family TypedDiff (s :: Schema) (d :: Diff) :: Constraint where
51type family TypedDiff (s :: Schema) (d :: Diff) :: Constraint where
46 TypedDiff s ('Diff ps a) = TypedSubSchema s ps
52 TypedDiff s ('Diff ps a) = TypedSubSchema s ps
47
53
54+type family TypedDiffSchema (s :: Schema) (d :: Diff) :: Schema where
55+ TypedDiffSchema s ('Diff ps a) = TypedSubSchemaSchema s ps
56+
48type family TypedSubSchema (s :: Schema) (p :: [PathSegment]) :: Constraint where
57type family TypedSubSchema (s :: Schema) (p :: [PathSegment]) :: Constraint where
49 TypedSubSchema s '[] = ()
58 TypedSubSchema s '[] = ()
50 TypedSubSchema s (h ': tl) = TypedSubSchema (TraverseStep s h) tl
59 TypedSubSchema s (h ': tl) = TypedSubSchema (TraverseStep s h) tl
51
60
61+type family TypedSubSchemaSchema (s :: Schema) (p :: [PathSegment]) :: Schema where
62+ TypedSubSchemaSchema s '[] = s
63+ TypedSubSchemaSchema s (h ': tl) = TypedSubSchemaSchema (TraverseStep s h) tl
64+
52type family TraverseStep (s :: Schema) (ps :: PathSegment) :: Schema where
65type family TraverseStep (s :: Schema) (ps :: PathSegment) :: Schema where
53 TraverseStep ('SchemaArray acs s) ('Ix n) = s
66 TraverseStep ('SchemaArray acs s) ('Ix n) = s
54 TraverseStep ('SchemaObject ( '(fn, s) ': tl)) ('Key fn) = s
67 TraverseStep ('SchemaObject ( '(fn, s) ': tl)) ('Key fn) = s
@@ -67,6 +80,9 @@ data Migration = Migration Revision [Diff]
67type family TypedMigration (s :: Schema) (m :: Migration) :: Constraint where
80type family TypedMigration (s :: Schema) (m :: Migration) :: Constraint where
68 TypedMigration s ('Migration r ds) = (TypedDiffList s ds)
81 TypedMigration s ('Migration r ds) = (TypedDiffList s ds)
69
82
83+type family TypedMigrationSchema (s :: Schema) (m :: Migration) :: (Symbol, Schema) where
84+ TypedMigrationSchema s ('Migration r ds) = '(r, TypedDiffListSchema s ds)
85+
70data instance Sing (m :: Migration) where
86data instance Sing (m :: Migration) where
71 SMigration
87 SMigration
72 :: (KnownSymbol r, Known (Sing ds))
88 :: (KnownSymbol r, Known (Sing ds))
@@ -76,9 +92,23 @@ data instance Sing (m :: Migration) where
76
92
77data Versioned = Versioned Schema [Migration]
93data Versioned = Versioned Schema [Migration]
78
94
95+type family TypedVersioned (s :: Schema) (ms :: [Migration]) :: Constraint where
96+ TypedVersioned s '[] = ()
97+ TypedVersioned s (h ': tl) =
98+ ( TypedMigration s h
99+ , MigrateSchema s (Snd (TypedMigrationSchema s h))
100+ , TypedVersioned (Snd (TypedMigrationSchema s h)) tl )
101+
102+type family TypedVersionedSchema
103+
79data instance Sing (v :: Versioned) where
104data instance Sing (v :: Versioned) where
80 SVersioned
105 SVersioned
81 :: (Known (Sing s), Known (Sing ms), TypedMigration s m)
106 :: (Known (Sing s), Known (Sing ms), TypedMigration s m)
82 => Sing (s :: Schema) -- base version
107 => Sing (s :: Schema) -- base version
83 -> Sing (ms :: [Migration]) -- a bunch of migrations
108 -> Sing (ms :: [Migration]) -- a bunch of migrations
84 -> Sing ('Versioned s ms)
109 -> Sing ('Versioned s ms)
110+
111+type family HeadVersion (vd :: Versioned) :: Schema where
112+ HeadVersion ('Versioned s '[]) = s
113+ HeadVersion ('Versioned s (m ': tl)) =
114+ HeadVersion ('Versioned (Snd (TypedMigrationSchema s m)) tl)