@@ -1,3 +1,4 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
12{-# LANGUAGE TemplateHaskell #-}
23
34module Data.Schematic.Migration where
@@ -6,7 +7,7 @@ import Data.Kind
67import Data.Schematic.Path
78import Data.Schematic.Schema
89import Data.Schematic.Utils
9−import Data.Singletons.Prelude
10+import Data.Singletons.Prelude hiding (All)
1011import Data.Singletons.TypeLits
1112
1213
@@ -26,19 +27,46 @@ instance (Known (Sing n), Known (Sing s)) => Known (Sing ('AddKey n s)) where
2627instance (Known (Sing s)) => Known (Sing ('Update s)) where known = SUpdate known
2728instance Known (Sing 'DeleteKey) where known = SDelete
2829
29−data Diff = DiffSchema [PathSegment] Action
30+-- | User-supplied atomic difference between schemas.
31+-- Migrations can consists of many differences.
32+data Diff = Diff [PathSegment] Action
3033
3134data instance Sing (diff :: Diff) where
3235 SDiff
3336 :: (Known (Sing jp), Known (Sing a))
3437 => Sing (jp :: [PathSegment])
3538 -> Sing (a :: Action)
36− -> Sing ('DiffSchema jp a)
39+ -> Sing ('Diff jp a)
3740
41+type family TypedDiffList (s :: Schema) (ds :: [Diff]) :: Constraint where
42+ TypedDiffList s '[] = ()
43+ TypedDiffList s (d ': tl) = (TypedDiff s d, TypedDiffList s tl)
44+
45+type family TypedDiff (s :: Schema) (d :: Diff) :: Constraint where
46+ TypedDiff s ('Diff ps a) = TypedSubSchema s ps
47+
48+type family TypedSubSchema (s :: Schema) (p :: [PathSegment]) :: Constraint where
49+ TypedSubSchema s '[] = ()
50+ TypedSubSchema s (h ': tl) = TypedSubSchema (TraverseStep s h) tl
51+
52+type family TraverseStep (s :: Schema) (ps :: PathSegment) :: Schema where
53+ TraverseStep ('SchemaArray acs s) ('Ix n) = s
54+ TraverseStep ('SchemaObject ( '(fn, s) ': tl)) ('Key fn) = s
55+ TraverseStep ('SchemaObject ( h ': tl)) ('Key fn) =
56+ TraverseStep ('SchemaObject tl) ('Key fn)
57+
58+type family SubSchema (s :: Schema) (p :: [PathSegment]) where
59+ SubSchema s '[] = s
60+ SubSchema s (h ': tl) = SubSchema (TraverseStep s h) tl
61+
62+-- | User-provided name of the revision.
3863type Revision = Symbol
3964
4065data Migration = Migration Revision [Diff]
4166
67+type family TypedMigration (s :: Schema) (m :: Migration) :: Constraint where
68+ TypedMigration s ('Migration r ds) = (TypedDiffList s ds)
69+
4270data instance Sing (m :: Migration) where
4371 SMigration
4472 :: (KnownSymbol r, Known (Sing ds))
@@ -46,17 +74,11 @@ data instance Sing (m :: Migration) where
4674 -> Sing ds
4775 -> Sing ('Migration r ds)
4876
49−data Versioned = Versioned
50− Schema -- base version
51− [Migration] -- a bunch of migrations
77+data Versioned = Versioned Schema [Migration]
5278
53−data instance (Sing (v :: Versioned)) where
79+data instance Sing (v :: Versioned) where
5480 SVersioned
55− :: (Known (Sing s), Known (Sing ms))
56− => Sing s
57− -> Sing ms
81+ :: (Known (Sing s), Known (Sing ms), TypedMigration s m)
82+ => Sing (s :: Schema) -- base version
83+ -> Sing (ms :: [Migration]) -- a bunch of migrations
5884 -> Sing ('Versioned s ms)
59−
60−type family Typed (s :: Schema) (ps :: PathSegment) :: Constraint where
61− Typed ('SchemaObject '[]) ('Key fn) = FalseConstraint fn
62− Typed ('SchemaObject ( '(fn, s) ': tl)) ('Key fn) = ()