@@ -0,0 +1,62 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+
3+module Data.Schematic.Migration where
4+
5+import Data.Kind
6+import Data.Schematic.Path
7+import Data.Schematic.Schema
8+import Data.Schematic.Utils
9+import Data.Singletons.Prelude
10+import Data.Singletons.TypeLits
11+
12+
13+data Action = AddKey Symbol Schema | Update Schema | DeleteKey
14+
15+data instance Sing (a :: Action) where
16+ SAddKey
17+ :: (Known (Sing n), Known (Sing s))
18+ => Sing n
19+ -> Sing s
20+ -> Sing ('AddKey n s)
21+ SUpdate :: Known (Sing s) => Sing s -> Sing ('Update s)
22+ SDelete :: Sing 'DeleteKey
23+
24+instance (Known (Sing n), Known (Sing s)) => Known (Sing ('AddKey n s)) where
25+ known = SAddKey known known
26+instance (Known (Sing s)) => Known (Sing ('Update s)) where known = SUpdate known
27+instance Known (Sing 'DeleteKey) where known = SDelete
28+
29+data Diff = DiffSchema [PathSegment] Action
30+
31+data instance Sing (diff :: Diff) where
32+ SDiff
33+ :: (Known (Sing jp), Known (Sing a))
34+ => Sing (jp :: [PathSegment])
35+ -> Sing (a :: Action)
36+ -> Sing ('DiffSchema jp a)
37+
38+type Revision = Symbol
39+
40+data Migration = Migration Revision [Diff]
41+
42+data instance Sing (m :: Migration) where
43+ SMigration
44+ :: (KnownSymbol r, Known (Sing ds))
45+ => Sing r
46+ -> Sing ds
47+ -> Sing ('Migration r ds)
48+
49+data Versioned = Versioned
50+ Schema -- base version
51+ [Migration] -- a bunch of migrations
52+
53+data instance (Sing (v :: Versioned)) where
54+ SVersioned
55+ :: (Known (Sing s), Known (Sing ms))
56+ => Sing s
57+ -> Sing ms
58+ -> 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) = ()