git.iko.soy/schematic
on union help sign in
schematic/src/Data/Schematic/Migration.hs
150 lines 5.0 kB history raw
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE TemplateHaskell #-}
4module Data.Schematic.Migration where
6import Data.Kind
7import Data.Schematic.Path
8import Data.Schematic.Schema
9import Data.Singletons.Prelude hiding (All)
10import Data.Singletons.TypeLits
13data Path
14 = PKey Symbol -- traverse into the object by key
15 | PTraverse -- traverse into the array
17data instance Sing (p :: Path) where
18 SPKey :: Sing s -> Sing ('PKey s)
19 SPTraverse :: Sing 'PTraverse
21instance KnownSymbol s => SingI ('PKey s) where
22 sing = SPKey sing
24instance SingI 'PTraverse where
25 sing = SPTraverse
27-- Result type blueprint
28data Builder
29 = BKey Schema Symbol Builder -- field schema
30 | BTraverse Schema Builder -- array schema
31 | BScalar Schema
33-- Working with keys
35type family SchemaByKey (fs :: [(Symbol, Schema)]) (s :: Symbol) :: Schema where
36 SchemaByKey ( '(fn,s) ': tl) fn = s
37 SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn
39type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: [(Symbol, Schema)] where
40 DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl
41 DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)
43type family UpdateKey
44 (fn :: Symbol)
45 (fs :: [(Symbol, Schema)])
46 (s :: Schema) = (r :: [(Symbol, Schema)]) where
47 UpdateKey fn ( '(fn, a) ': tl ) s = ( '(fn, s) ': tl )
48 UpdateKey fn ( '(fs, a) ': tl ) s = ( '(fs, a) ': UpdateKey fn tl s)
50-- schema updates
52type family Build (b :: Builder) :: Schema where
53 Build ('BKey ('SchemaObject fs) fn z) = 'SchemaObject (UpdateKey fn fs (Build z))
54 Build ('BTraverse ('SchemaArray acs s) z) = 'SchemaArray acs (Build z)
55 Build ('BScalar s) = s
57type family MakeBuilder (s :: Schema) (d :: Diff) :: Builder where
58 MakeBuilder s ('Diff '[] a) = 'BScalar (ApplyAction a s)
59 MakeBuilder ('SchemaObject fs) ('Diff ('PKey fn ': tl) a) =
60 'BKey ('SchemaObject fs) fn (MakeBuilder (SchemaByKey fs fn) ('Diff tl a))
61 MakeBuilder ('SchemaArray acs s) ('Diff ('PTraverse ': tl) a) =
62 'BTraverse ('SchemaArray acs s) (MakeBuilder s ('Diff tl a))
64type family ApplyAction (a :: Action) (s :: Schema) :: Schema where
65 ApplyAction ('AddKey fn s) ('SchemaObject fs) = 'SchemaObject ('(fn,s) ': fs)
66 ApplyAction ('DeleteKey fn) ('SchemaObject fs) = 'SchemaObject (DeleteKey '[] fn fs)
67 ApplyAction ('Update s) t = s
69type family ApplyMigration (m :: Migration) (s :: Schema) :: (Revision, Schema) where
70 ApplyMigration ('Migration r '[]) s = '(r, s)
71 ApplyMigration ('Migration r (d ': ds)) s =
72 '(r, Snd (ApplyMigration ('Migration r ds) (Build (MakeBuilder s d))))
74-- working with revisions
76type family SchemaByRevision (r :: Revision) (vd :: Versioned) :: Schema where
77 SchemaByRevision r ('Versioned s (('Migration r ds) ': ms)) =
78 Snd (ApplyMigration ('Migration r ds) s)
79 SchemaByRevision r ('Versioned s (m ': ms)) =
80 SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
82type family InitialSchema (v :: Versioned) = (s :: Schema) where
83 InitialSchema ('Versioned s ms) = s
85type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
86 ElemOf e '[] = 'True ~ 'False
87 ElemOf e ( '(a, e) ': es) = ()
88 ElemOf e (n ': es) = ElemOf e es
90-- | Extracts revision/schema pairs from @Versioned@ in reverse order.
91type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where
92 AllVersions ('Versioned s ms) = Reverse (AllVersions' '[ '("initial", s) ] ms)
94type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration]) = (r :: [(Revision, Schema)]) where
95 AllVersions' acc '[] = acc
96 AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =
97 AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms
99type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where
100 TopVersion ( '(rh, sh) ': tl) = sh
102data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
104data instance Sing (a :: Action) where
105 SAddKey
106 :: Sing n
107 -> Sing s
108 -> Sing ('AddKey n s)
109 SUpdate :: Sing s -> Sing ('Update s)
110 SDeleteKey :: Sing s -> Sing ('DeleteKey s)
112-- | User-supplied atomic difference between schemas.
113-- Migrations can consists of many differences.
114data Diff = Diff [Path] Action
116data instance Sing (diff :: Diff) where
117 SDiff
118 :: Sing (jp :: [Path])
119 -> Sing (a :: Action)
120 -> Sing ('Diff jp a)
122-- | User-provided name of the revision.
123type Revision = Symbol
125data Migration = Migration Revision [Diff]
127data instance Sing (m :: Migration) where
128 SMigration
129 :: Sing r
130 -> Sing ds
131 -> Sing ('Migration r ds)
133data Versioned = Versioned Schema [Migration]
135data instance Sing (v :: Versioned) where
136 SVersioned
137 :: Sing (s :: Schema) -- base version
138 -> Sing (ms :: [Migration]) -- a bunch of migrations
139 -> Sing ('Versioned s ms)
141data MList :: (* -> *) -> [Schema] -> Type where
142 MNil :: (Monad m, SingI s, TopLevel s) => MList m '[s]
143 (:&&)
144 :: (TopLevel s, SingI s)
145 => proxy s
146 -> (JsonRepr h -> m (JsonRepr s))
147 -> MList m (h ': tl)
148 -> MList m (s ': h ': tl)
150infixr 7 :&&