@@ -1,3 +1,4 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE TemplateHaskell #-}
3module Data.Schematic.Migration where
4module Data.Schematic.Migration where
@@ -6,7 +7,7 @@ import Data.Kind
6import Data.Schematic.Path
7import Data.Schematic.Path
7import Data.Schematic.Schema
8import Data.Schematic.Schema
8import Data.Schematic.Utils
9import Data.Schematic.Utils
9−import Data.Singletons.Prelude
10+import Data.Singletons.Prelude hiding (All)
10import Data.Singletons.TypeLits
11import Data.Singletons.TypeLits
@@ -26,19 +27,46 @@ instance (Known (Sing n), Known (Sing s)) => Known (Sing ('AddKey n s)) where
26instance (Known (Sing s)) => Known (Sing ('Update s)) where known = SUpdate known
27instance (Known (Sing s)) => Known (Sing ('Update s)) where known = SUpdate known
27instance Known (Sing 'DeleteKey) where known = SDelete
28instance Known (Sing 'DeleteKey) where known = SDelete
30+-- | User-supplied atomic difference between schemas.
31+-- Migrations can consists of many differences.
29−data Diff = DiffSchema [PathSegment] Action
32+data Diff = Diff [PathSegment] Action
31data instance Sing (diff :: Diff) where
34data instance Sing (diff :: Diff) where
33 :: (Known (Sing jp), Known (Sing a))
36 :: (Known (Sing jp), Known (Sing a))
34 => Sing (jp :: [PathSegment])
37 => Sing (jp :: [PathSegment])
35 -> Sing (a :: Action)
38 -> Sing (a :: Action)
36− -> Sing ('DiffSchema jp a)
39+ -> Sing ('Diff jp a)
41+type family TypedDiffList (s :: Schema) (ds :: [Diff]) :: Constraint where
42+ TypedDiffList s '[] = ()
43+ TypedDiffList s (d ': tl) = (TypedDiff s d, TypedDiffList s tl)
45+type family TypedDiff (s :: Schema) (d :: Diff) :: Constraint where
46+ TypedDiff s ('Diff ps a) = TypedSubSchema s ps
48+type family TypedSubSchema (s :: Schema) (p :: [PathSegment]) :: Constraint where
49+ TypedSubSchema s '[] = ()
50+ TypedSubSchema s (h ': tl) = TypedSubSchema (TraverseStep s h) tl
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)
58+type family SubSchema (s :: Schema) (p :: [PathSegment]) where
60+ SubSchema s (h ': tl) = SubSchema (TraverseStep s h) tl
62+-- | User-provided name of the revision.
38type Revision = Symbol
63type Revision = Symbol
40data Migration = Migration Revision [Diff]
65data Migration = Migration Revision [Diff]
67+type family TypedMigration (s :: Schema) (m :: Migration) :: Constraint where
68+ TypedMigration s ('Migration r ds) = (TypedDiffList s ds)
42data instance Sing (m :: Migration) where
70data instance Sing (m :: Migration) where
43 SMigration
71 SMigration
44 :: (KnownSymbol r, Known (Sing ds))
72 :: (KnownSymbol r, Known (Sing ds))
@@ -46,17 +74,11 @@ data instance Sing (m :: Migration) where
46 -> Sing ds
74 -> Sing ds
47 -> Sing ('Migration r ds)
75 -> Sing ('Migration r ds)
49−data Versioned = Versioned
77+data Versioned = Versioned Schema [Migration]
50− Schema -- base version
51− [Migration] -- a bunch of migrations
53−data instance (Sing (v :: Versioned)) where
79+data instance Sing (v :: Versioned) where
54 SVersioned
80 SVersioned
55− :: (Known (Sing s), Known (Sing ms))
81+ :: (Known (Sing s), Known (Sing ms), TypedMigration s m)
56− => Sing s
82+ => Sing (s :: Schema) -- base version
57− -> Sing ms
83+ -> Sing (ms :: [Migration]) -- a bunch of migrations
58 -> Sing ('Versioned s ms)
84 -> Sing ('Versioned s ms)
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) = ()