@@ -10,6 +10,8 @@ import Data.Schematic.Utils
1010import Data.Singletons.Prelude hiding (All)
1111import Data.Singletons.TypeLits
1212
13+class MigrateSchema (a :: Schema) (b :: Schema) where
14+ migrate :: JsonRepr a -> JsonRepr b
1315
1416data Action = AddKey Symbol Schema | Update Schema | DeleteKey
1517
@@ -42,13 +44,24 @@ type family TypedDiffList (s :: Schema) (ds :: [Diff]) :: Constraint where
4244 TypedDiffList s '[] = ()
4345 TypedDiffList s (d ': tl) = (TypedDiff s d, TypedDiffList s tl)
4446
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+
4551type family TypedDiff (s :: Schema) (d :: Diff) :: Constraint where
4652 TypedDiff s ('Diff ps a) = TypedSubSchema s ps
4753
54+type family TypedDiffSchema (s :: Schema) (d :: Diff) :: Schema where
55+ TypedDiffSchema s ('Diff ps a) = TypedSubSchemaSchema s ps
56+
4857type family TypedSubSchema (s :: Schema) (p :: [PathSegment]) :: Constraint where
4958 TypedSubSchema s '[] = ()
5059 TypedSubSchema s (h ': tl) = TypedSubSchema (TraverseStep s h) tl
5160
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+
5265type family TraverseStep (s :: Schema) (ps :: PathSegment) :: Schema where
5366 TraverseStep ('SchemaArray acs s) ('Ix n) = s
5467 TraverseStep ('SchemaObject ( '(fn, s) ': tl)) ('Key fn) = s
@@ -67,6 +80,9 @@ data Migration = Migration Revision [Diff]
6780type family TypedMigration (s :: Schema) (m :: Migration) :: Constraint where
6881 TypedMigration s ('Migration r ds) = (TypedDiffList s ds)
6982
83+type family TypedMigrationSchema (s :: Schema) (m :: Migration) :: (Symbol, Schema) where
84+ TypedMigrationSchema s ('Migration r ds) = '(r, TypedDiffListSchema s ds)
85+
7086data instance Sing (m :: Migration) where
7187 SMigration
7288 :: (KnownSymbol r, Known (Sing ds))
@@ -76,9 +92,23 @@ data instance Sing (m :: Migration) where
7692
7793data Versioned = Versioned Schema [Migration]
7894
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+
79104data instance Sing (v :: Versioned) where
80105 SVersioned
81106 :: (Known (Sing s), Known (Sing ms), TypedMigration s m)
82107 => Sing (s :: Schema) -- base version
83108 -> Sing (ms :: [Migration]) -- a bunch of migrations
84109 -> 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)